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
dist-newstyle/
dist/
*.hp
*.ps
*.pdf

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

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)