From 8967cdfdea3d38f70f427993cdff986fd5a6a698 Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 17 Apr 2019 07:51:15 +0200 Subject: [PATCH] foobar --- .gitignore | 1 + mateamt.cabal | 3 +++ shell.nix | 11 +++++---- src/API.hs | 7 +++++- src/Main.hs | 25 ++++++++++++++++--- src/Model/User.hs | 58 +++++++++++++++++++++++++------------------ src/Types.hs | 24 ++++-------------- src/Types/Auth.hs | 60 +++++++++++++++++++++++++++++++++++++++++++++ src/Types/Refine.hs | 20 +++++++++++++++ 9 files changed, 157 insertions(+), 52 deletions(-) create mode 100644 src/Types/Auth.hs create mode 100644 src/Types/Refine.hs diff --git a/.gitignore b/.gitignore index 223c20b..53e6edc 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,6 @@ *.swp dist-newstyle/ +dist/ *.hp *.ps *.pdf diff --git a/mateamt.cabal b/mateamt.cabal index b3b6c7a..a15be2f 100644 --- a/mateamt.cabal +++ b/mateamt.cabal @@ -22,6 +22,8 @@ executable mateamt , Model.User , Model.Beverage , Types + , Types.Refine + , Types.Auth -- other-extensions: build-depends: base ^>=4.12.0.0 , servant @@ -36,5 +38,6 @@ executable mateamt , wai , wai-logger , http-api-data + , bytestring hs-source-dirs: src default-language: Haskell2010 diff --git a/shell.nix b/shell.nix index f2c9686..1c7e506 100644 --- a/shell.nix +++ b/shell.nix @@ -4,9 +4,9 @@ let inherit (nixpkgs) pkgs; - f = { mkDerivation, aeson, base, opaleye, postgresql-simple - , product-profunctors, servant, servant-server, stdenv, text, time - , warp + f = { mkDerivation, aeson, base, bytestring, http-api-data + , opaleye, postgresql-simple, product-profunctors, servant + , servant-server, stdenv, text, time, wai, wai-logger, warp }: mkDerivation { pname = "mateamt"; @@ -15,8 +15,9 @@ let isLibrary = false; isExecutable = true; executableHaskellDepends = [ - aeson base opaleye postgresql-simple product-profunctors servant - servant-server text time warp + aeson base bytestring http-api-data opaleye postgresql-simple + product-profunctors servant servant-server text time wai wai-logger + warp ]; description = "A whole new matemat"; license = stdenv.lib.licenses.agpl3; diff --git a/src/API.hs b/src/API.hs index 8eafe48..6650b1f 100644 --- a/src/API.hs +++ b/src/API.hs @@ -23,7 +23,12 @@ import Types type UserAPI = "user" :> - ( "list" :> QueryParam "refine" Refine :> Get '[JSON] [User] + ( "list" :> QueryParam "refine" Refine + :> AuthProtect "header-auth" :> Get '[JSON] [User] :<|> "new" :> ReqBody '[JSON] UserSubmit :> Post '[JSON] Int :<|> "update" :> ReqBody '[JSON] (Int, UserSubmit) :> Post '[JSON] () ) + :<|> "auth" :> + ( "get" :> ReqBody '[JSON] Int :> Post '[JSON] AuthInfo + :<|> "send" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] AuthResult + ) diff --git a/src/Main.hs b/src/Main.hs index 6ec2237..95cf3e9 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,7 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} module Main where import Servant +import Servant.Server.Experimental.Auth import Data.Time.Clock @@ -35,19 +39,34 @@ main = do runSettings settings (app conn) app :: Connection -> Application -app conn = serve userApi (users conn) +app conn = serveWithContext userApi genAuthServerContext (users conn) userApi :: Proxy UserAPI userApi = Proxy +genAuthServerContext :: Context (AuthHandler Request Bool ': '[]) +genAuthServerContext = authHandler Servant.:. EmptyContext + +type instance AuthServerData (AuthProtect "header-auth") = Bool + +authHandler :: AuthHandler Request Bool +authHandler = mkAuthHandler handler + where + handler req = do + let headers = requestHeaders req + res = case lookup "Authorization" headers of + Just _ -> True + _ -> False + return res + users :: Connection -> Server UserAPI users conn = userList :<|> userNew :<|> userUpdate where - userList :: Maybe Refine -> Handler [User] - userList ref = liftIO $ userSelect conn ref + userList :: Maybe Refine -> Bool -> Handler [User] + userList ref sw = liftIO $ userSelect conn ref sw userNew :: UserSubmit -> Handler Int userNew us = liftIO $ do now <- getCurrentTime diff --git a/src/Model/User.hs b/src/Model/User.hs index 4ba0286..5a938db 100644 --- a/src/Model/User.hs +++ b/src/Model/User.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} module Model.User where import Data.Text as T @@ -24,18 +25,24 @@ import qualified Opaleye.Constant as C -- internal imports -import Types +import Types.Refine -data User = User - { userId :: Int - , userIdent :: T.Text - , userBalance :: Int - , userTimeStamp :: Day - , userEmail :: Maybe T.Text - , userAvatar :: Maybe Int - , userPin :: Maybe T.Text - } - deriving (Generic, Show) +data User + = User + { userId :: Int + , userIdent :: T.Text + , userBalance :: Int + , userTimeStamp :: Day + , userEmail :: Maybe T.Text + , userAvatar :: Maybe Int + , userPin :: Maybe T.Text + } + | QueryUser + { userId :: Int + , userIdent :: T.Text + , userAvatar :: Maybe Int + } + deriving (Generic, Show) instance ToJSON User where toEncoding (User id ident balance ts email avatar _) = @@ -47,6 +54,12 @@ instance ToJSON User where <> "userEmail" .= email <> "userAvatar" .= avatar ) + toEncoding (QueryUser id ident avatar) = + pairs + ( "userId" .= id + <> "userIdent" .= ident + <> "userAvatar" .= avatar + ) instance FromJSON User @@ -97,21 +110,11 @@ userTable = table "user" ( userSelect :: PGS.Connection -> Maybe Refine + -> Bool -> IO [User] -userSelect conn ref = do +userSelect conn ref sw = do today <- utctDay <$> getCurrentTime - (mapM - (\(i1, i2, i3, i4, i5, i6, i7) -> return $ - User - i1 - i2 - i3 - i4 - i5 - i6 - i7 - ) - ) =<< runSelect conn (case ref of + users <- runSelect conn (case ref of Nothing -> keepWhen (\(_, _, _, ts, _, _, _) -> ts .>= C.constant (addDays (-30) today) ) <<< queryTable userTable @@ -119,7 +122,14 @@ userSelect conn ref = do Just Old -> keepWhen (\(_, _, _, ts, _, _, _) -> ts .<= C.constant (addDays (-30) today) ) <<< queryTable userTable + ) :: IO [(Int, Text, Int, Day, Maybe Text, Maybe Int, Maybe Text)] + mapM + (\(i1, i2, i3, i4, i5, i6, i7) -> return $ + if sw + then User i1 i2 i3 i4 i5 i6 i7 + else QueryUser i1 i2 i6 ) + users insertUser :: UserSubmit -> Day -> Insert [Int] insertUser us now = Insert diff --git a/src/Types.hs b/src/Types.hs index 6560789..131d11c 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,20 +1,6 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} +module Types + ( module T + ) where -module Types where - -import Data.Text - -import GHC.Generics - -import Web.HttpApiData - -data Refine = All | Old - deriving (Generic, Show, Enum) - -instance FromHttpApiData Refine where - parseQueryParam t = - case t of - "all" -> Right All - "old" -> Right Old - x -> Left ("Error: Unknown refine " <> x) +import Types.Refine as T +import Types.Auth as T diff --git a/src/Types/Auth.hs b/src/Types/Auth.hs new file mode 100644 index 0000000..2410fdd --- /dev/null +++ b/src/Types/Auth.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Types.Auth where + +import GHC.Generics + +import Data.Aeson + +import Data.ByteString + +data AuthInfo = AuthInfo + { authSalt :: AuthSalt + , authAlgorithm :: AuthAlgorithm + } + deriving (Show, Generic) + +instance ToJSON AuthInfo where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON AuthInfo + +data AuthAlgorithm + = PBKDF2 + deriving (Show, Generic) + +instance ToJSON AuthAlgorithm where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON AuthAlgorithm + +type AuthSalt = ByteString + +instance ToJSON AuthSalt where + toJSON salt = object (toHex salt) + +instance FromJSON AuthSalt + +data AuthRequest = AuthRequest + { requestUser :: Int + , requestHash :: ByteString + } + deriving (Show, Generic) + +instance ToJSON AuthRequest where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON AuthRequest + +data AuthResult + = Granted + { authToken :: ByteString + } + | Denied + deriving (Show, Generic) + +instance ToJSON AuthResult where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON AuthResult diff --git a/src/Types/Refine.hs b/src/Types/Refine.hs new file mode 100644 index 0000000..c88deb3 --- /dev/null +++ b/src/Types/Refine.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Types.Refine where + +import Data.Text + +import GHC.Generics + +import Web.HttpApiData + +data Refine = All | Old + deriving (Generic, Show, Enum) + +instance FromHttpApiData Refine where + parseQueryParam t = + case t of + "all" -> Right All + "old" -> Right Old + x -> Left ("Error: Unknown refine " <> x)