This commit is contained in:
nek0 2019-04-17 07:51:15 +02:00
parent 1a8f09d2ad
commit 8967cdfdea
9 changed files with 157 additions and 52 deletions

1
.gitignore vendored
View file

@ -1,5 +1,6 @@
*.swp *.swp
dist-newstyle/ dist-newstyle/
dist/
*.hp *.hp
*.ps *.ps
*.pdf *.pdf

View file

@ -22,6 +22,8 @@ executable mateamt
, Model.User , Model.User
, Model.Beverage , Model.Beverage
, Types , Types
, Types.Refine
, Types.Auth
-- other-extensions: -- other-extensions:
build-depends: base ^>=4.12.0.0 build-depends: base ^>=4.12.0.0
, servant , servant
@ -36,5 +38,6 @@ executable mateamt
, wai , wai
, wai-logger , wai-logger
, http-api-data , http-api-data
, bytestring
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010

View file

@ -4,9 +4,9 @@ let
inherit (nixpkgs) pkgs; inherit (nixpkgs) pkgs;
f = { mkDerivation, aeson, base, opaleye, postgresql-simple f = { mkDerivation, aeson, base, bytestring, http-api-data
, product-profunctors, servant, servant-server, stdenv, text, time , opaleye, postgresql-simple, product-profunctors, servant
, warp , servant-server, stdenv, text, time, wai, wai-logger, warp
}: }:
mkDerivation { mkDerivation {
pname = "mateamt"; pname = "mateamt";
@ -15,8 +15,9 @@ let
isLibrary = false; isLibrary = false;
isExecutable = true; isExecutable = true;
executableHaskellDepends = [ executableHaskellDepends = [
aeson base opaleye postgresql-simple product-profunctors servant aeson base bytestring http-api-data opaleye postgresql-simple
servant-server text time warp product-profunctors servant servant-server text time wai wai-logger
warp
]; ];
description = "A whole new matemat"; description = "A whole new matemat";
license = stdenv.lib.licenses.agpl3; license = stdenv.lib.licenses.agpl3;

View file

@ -23,7 +23,12 @@ import Types
type UserAPI = type UserAPI =
"user" :> "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 :<|> "new" :> ReqBody '[JSON] UserSubmit :> Post '[JSON] Int
:<|> "update" :> ReqBody '[JSON] (Int, UserSubmit) :> Post '[JSON] () :<|> "update" :> ReqBody '[JSON] (Int, UserSubmit) :> Post '[JSON] ()
) )
:<|> "auth" :>
( "get" :> ReqBody '[JSON] Int :> Post '[JSON] AuthInfo
:<|> "send" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] AuthResult
)

View file

@ -1,7 +1,11 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
module Main where module Main where
import Servant import Servant
import Servant.Server.Experimental.Auth
import Data.Time.Clock import Data.Time.Clock
@ -35,19 +39,34 @@ main = do
runSettings settings (app conn) runSettings settings (app conn)
app :: Connection -> Application app :: Connection -> Application
app conn = serve userApi (users conn) app conn = serveWithContext userApi genAuthServerContext (users conn)
userApi :: Proxy UserAPI userApi :: Proxy UserAPI
userApi = Proxy 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 :: Connection -> Server UserAPI
users conn = users conn =
userList :<|> userList :<|>
userNew :<|> userNew :<|>
userUpdate userUpdate
where where
userList :: Maybe Refine -> Handler [User] userList :: Maybe Refine -> Bool -> Handler [User]
userList ref = liftIO $ userSelect conn ref userList ref sw = liftIO $ userSelect conn ref sw
userNew :: UserSubmit -> Handler Int userNew :: UserSubmit -> Handler Int
userNew us = liftIO $ do userNew us = liftIO $ do
now <- getCurrentTime now <- getCurrentTime

View file

@ -1,5 +1,6 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Model.User where module Model.User where
import Data.Text as T import Data.Text as T
@ -24,18 +25,24 @@ import qualified Opaleye.Constant as C
-- internal imports -- internal imports
import Types import Types.Refine
data User = User data User
{ userId :: Int = User
, userIdent :: T.Text { userId :: Int
, userBalance :: Int , userIdent :: T.Text
, userTimeStamp :: Day , userBalance :: Int
, userEmail :: Maybe T.Text , userTimeStamp :: Day
, userAvatar :: Maybe Int , userEmail :: Maybe T.Text
, userPin :: Maybe T.Text , userAvatar :: Maybe Int
} , userPin :: Maybe T.Text
deriving (Generic, Show) }
| QueryUser
{ userId :: Int
, userIdent :: T.Text
, userAvatar :: Maybe Int
}
deriving (Generic, Show)
instance ToJSON User where instance ToJSON User where
toEncoding (User id ident balance ts email avatar _) = toEncoding (User id ident balance ts email avatar _) =
@ -47,6 +54,12 @@ instance ToJSON User where
<> "userEmail" .= email <> "userEmail" .= email
<> "userAvatar" .= avatar <> "userAvatar" .= avatar
) )
toEncoding (QueryUser id ident avatar) =
pairs
( "userId" .= id
<> "userIdent" .= ident
<> "userAvatar" .= avatar
)
instance FromJSON User instance FromJSON User
@ -97,21 +110,11 @@ userTable = table "user" (
userSelect userSelect
:: PGS.Connection :: PGS.Connection
-> Maybe Refine -> Maybe Refine
-> Bool
-> IO [User] -> IO [User]
userSelect conn ref = do userSelect conn ref sw = do
today <- utctDay <$> getCurrentTime today <- utctDay <$> getCurrentTime
(mapM users <- runSelect conn (case ref of
(\(i1, i2, i3, i4, i5, i6, i7) -> return $
User
i1
i2
i3
i4
i5
i6
i7
)
) =<< runSelect conn (case ref of
Nothing -> keepWhen (\(_, _, _, ts, _, _, _) -> Nothing -> keepWhen (\(_, _, _, ts, _, _, _) ->
ts .>= C.constant (addDays (-30) today) ts .>= C.constant (addDays (-30) today)
) <<< queryTable userTable ) <<< queryTable userTable
@ -119,7 +122,14 @@ userSelect conn ref = do
Just Old -> keepWhen (\(_, _, _, ts, _, _, _) -> Just Old -> keepWhen (\(_, _, _, ts, _, _, _) ->
ts .<= C.constant (addDays (-30) today) ts .<= C.constant (addDays (-30) today)
) <<< queryTable userTable ) <<< 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 :: UserSubmit -> Day -> Insert [Int]
insertUser us now = Insert insertUser us now = Insert

View file

@ -1,20 +1,6 @@
{-# LANGUAGE DeriveGeneric #-} module Types
{-# LANGUAGE OverloadedStrings #-} ( module T
) where
module Types where import Types.Refine as T
import Types.Auth as T
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)

60
src/Types/Auth.hs Normal file
View file

@ -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

20
src/Types/Refine.hs Normal file
View file

@ -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)