git vomit

This commit is contained in:
nek0 2019-04-17 10:45:48 +02:00
parent 8967cdfdea
commit 961fab0c88
4 changed files with 131 additions and 35 deletions

View file

@ -39,5 +39,6 @@ executable mateamt
, wai-logger , wai-logger
, http-api-data , http-api-data
, bytestring , bytestring
, base16-bytestring
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010

View file

@ -61,17 +61,29 @@ authHandler = mkAuthHandler handler
users :: Connection -> Server UserAPI users :: Connection -> Server UserAPI
users conn = users conn =
userList :<|> ( userList :<|>
userNew :<|> userNew :<|>
userUpdate userUpdate
) :<|>
( authGet :<|>
authSend
)
where where
userList :: Maybe Refine -> Bool -> Handler [User] userList :: Maybe Refine -> Bool -> Handler [User]
userList ref sw = liftIO $ userSelect conn ref sw 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
head <$> runInsert_ conn (insertUser us (utctDay now)) head <$> runInsert_ conn (insertUser us (utctDay now))
userUpdate :: (Int, UserSubmit) -> Handler () userUpdate :: (Int, UserSubmit) -> Handler ()
userUpdate (id, us) = liftIO $ do userUpdate (id, us) = liftIO $ do
now <- getCurrentTime now <- getCurrentTime
void $ runUpdate_ conn (updateUser id us (utctDay now)) void $ runUpdate_ conn (updateUser id us (utctDay now))
authGet :: Int -> Handler AuthInfo
authGet = liftIO . getUserAuthInfo conn
authSend :: AuthRequest -> Handler AuthResult
authSend _ = pure $ Granted $ AuthToken "mockgrant"

View file

@ -3,16 +3,18 @@
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
module Model.User where module Model.User where
import Data.Text as T import Data.Text as T hiding (head)
import Data.Time.Calendar import Data.Time.Calendar
import Data.Time.Clock import Data.Time.Clock
import Data.Profunctor.Product (p7) import Data.Profunctor.Product (p9)
import Data.Aeson import Data.Aeson
import Data.Int (Int64) import Data.Int (Int64)
import Data.Maybe (fromJust) import Data.Maybe (fromJust, fromMaybe)
import Data.ByteString hiding (head)
import qualified Database.PostgreSQL.Simple as PGS import qualified Database.PostgreSQL.Simple as PGS
@ -26,6 +28,7 @@ import qualified Opaleye.Constant as C
-- internal imports -- internal imports
import Types.Refine import Types.Refine
import Types.Auth
data User data User
= User = User
@ -35,7 +38,9 @@ data User
, userTimeStamp :: Day , userTimeStamp :: Day
, userEmail :: Maybe T.Text , userEmail :: Maybe T.Text
, userAvatar :: Maybe Int , userAvatar :: Maybe Int
, userPin :: Maybe T.Text , userSalt :: AuthSalt
, userHash :: Maybe AuthHash
, userAlgo :: Maybe Int
} }
| QueryUser | QueryUser
{ userId :: Int { userId :: Int
@ -45,7 +50,7 @@ data User
deriving (Generic, Show) 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 _ _ _) =
pairs pairs
( "userId" .= id ( "userId" .= id
<> "userIdent" .= ident <> "userIdent" .= ident
@ -66,7 +71,7 @@ instance FromJSON User
data UserSubmit = UserSubmit data UserSubmit = UserSubmit
{ userSubmitIdent :: T.Text { userSubmitIdent :: T.Text
, userSubmitEmail :: Maybe T.Text , userSubmitEmail :: Maybe T.Text
, userSubmitPin :: Maybe T.Text --, userSubmitPin :: Maybe T.Text
} }
deriving (Generic, Show) deriving (Generic, Show)
@ -76,7 +81,7 @@ instance ToJSON UserSubmit where
instance FromJSON UserSubmit instance FromJSON UserSubmit
initUser :: PGS.Query initUser :: PGS.Query
initUser = "create table if not exists \"user\" (id serial primary key, ident varchar(128) not null, balance integer not null, time_stamp date not null, email varchar(128), avatar integer, pin varchar(128))" initUser = "create table if not exists \"user\" (id serial primary key, ident varchar(128) not null, balance integer not null, time_stamp date not null, email varchar(128), avatar integer, salt bytea not null, hash bytea, algo integer)"
userTable :: Table userTable :: Table
( Maybe (Field SqlInt4) ( Maybe (Field SqlInt4)
@ -85,7 +90,9 @@ userTable :: Table
, Field SqlDate , Field SqlDate
, FieldNullable SqlText , FieldNullable SqlText
, FieldNullable SqlInt4 , FieldNullable SqlInt4
, FieldNullable SqlText , Field SqlBytea
, FieldNullable SqlBytea
, FieldNullable SqlInt4
) )
( Field SqlInt4 ( Field SqlInt4
, Field SqlText , Field SqlText
@ -93,17 +100,21 @@ userTable :: Table
, Field SqlDate , Field SqlDate
, FieldNullable SqlText , FieldNullable SqlText
, FieldNullable SqlInt4 , FieldNullable SqlInt4
, FieldNullable SqlText , Field SqlBytea
, FieldNullable SqlBytea
, FieldNullable SqlInt4
) )
userTable = table "user" ( userTable = table "user" (
p7 p9
( tableField "id" ( tableField "id"
, tableField "ident" , tableField "ident"
, tableField "balance" , tableField "balance"
, tableField "time_stamp" , tableField "time_stamp"
, tableField "email" , tableField "email"
, tableField "avatar" , tableField "avatar"
, tableField "pin" , tableField "salt"
, tableField "hash"
, tableField "algo"
) )
) )
@ -115,22 +126,58 @@ userSelect
userSelect conn ref sw = do userSelect conn ref sw = do
today <- utctDay <$> getCurrentTime today <- utctDay <$> getCurrentTime
users <- runSelect conn (case ref of users <- 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
Just All -> selectTable userTable Just All -> selectTable userTable
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)] ) :: IO
[ ( Int
, Text
, Int
, Day
, Maybe Text
, Maybe Int
, ByteString
, Maybe ByteString
, Maybe Int
)
]
mapM mapM
(\(i1, i2, i3, i4, i5, i6, i7) -> return $ (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> return $
if sw if sw
then User i1 i2 i3 i4 i5 i6 i7 then User i1 i2 i3 i4 i5 i6 (AuthSalt i7) (AuthHash <$> i8) (toEnum <$> i9)
else QueryUser i1 i2 i6 else QueryUser i1 i2 i6
) )
users users
getUserAuthInfo
:: PGS.Connection
-> Int
-> IO AuthInfo
getUserAuthInfo conn id = do
users <- runSelect conn (
keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
uid .== C.constant id) <<< queryTable userTable
) :: IO
[ ( Int
, Text
, Int
, Day
, Maybe Text
, Maybe Int
, ByteString
, Maybe ByteString
, Maybe Int
)
]
head <$> mapM (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> return $
AuthInfo (AuthSalt i7) (fromMaybe PBKDF2 $ (toEnum <$> i9))
)
users
insertUser :: UserSubmit -> Day -> Insert [Int] insertUser :: UserSubmit -> Day -> Insert [Int]
insertUser us now = Insert insertUser us now = Insert
{ iTable = userTable { iTable = userTable
@ -142,26 +189,30 @@ insertUser us now = Insert
, C.constant now , C.constant now
, C.constant (userSubmitEmail us) , C.constant (userSubmitEmail us)
, C.constant (Nothing :: Maybe Int) , C.constant (Nothing :: Maybe Int)
, C.constant (userSubmitPin us) , C.constant ("mocksalt" :: ByteString)
, C.constant (Nothing :: Maybe ByteString)
, C.constant (Nothing :: Maybe Int)
) )
] ]
, iReturning = rReturning (\(id, _, _, _, _, _, _) -> id) , iReturning = rReturning (\(id, _, _, _, _, _, _, _, _) -> id)
, iOnConflict = Nothing , iOnConflict = Nothing
} }
updateUser :: Int -> UserSubmit -> Day -> Update Int64 updateUser :: Int -> UserSubmit -> Day -> Update Int64
updateUser id us now = Update updateUser id us now = Update
{ uTable = userTable { uTable = userTable
, uUpdateWith = updateEasy (\(id_, _, i3, _, _, i6, _) -> , uUpdateWith = updateEasy (\(id_, _, i3, _, _, i6, i7, i8, i9) ->
( id_ ( id_
, C.constant (userSubmitIdent us) , C.constant (userSubmitIdent us)
, i3 , i3
, C.constant (now) , C.constant (now)
, C.constant (userSubmitEmail us) , C.constant (userSubmitEmail us)
, i6 , i6
, C.constant (userSubmitPin us) , i7
, i8
, i9
) )
) )
, uWhere = (\(i1, _, _, _, _, _, _) -> i1 .== C.constant id) , uWhere = (\(i1, _, _, _, _, _, _, _, _) -> i1 .== C.constant id)
, uReturning = rCount , uReturning = rCount
} }

View file

@ -1,6 +1,6 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Types.Auth where module Types.Auth where
import GHC.Generics import GHC.Generics
@ -8,6 +8,9 @@ import GHC.Generics
import Data.Aeson import Data.Aeson
import Data.ByteString import Data.ByteString
import qualified Data.ByteString.Base16 as B16
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
data AuthInfo = AuthInfo data AuthInfo = AuthInfo
{ authSalt :: AuthSalt { authSalt :: AuthSalt
@ -16,45 +19,74 @@ data AuthInfo = AuthInfo
deriving (Show, Generic) deriving (Show, Generic)
instance ToJSON AuthInfo where instance ToJSON AuthInfo where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthInfo instance FromJSON AuthInfo
data AuthAlgorithm data AuthAlgorithm
= PBKDF2 = PBKDF2
deriving (Show, Generic) deriving (Show, Generic, Enum)
instance ToJSON AuthAlgorithm where instance ToJSON AuthAlgorithm where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthAlgorithm instance FromJSON AuthAlgorithm
type AuthSalt = ByteString newtype AuthSalt = AuthSalt ByteString deriving (Show)
instance ToJSON AuthSalt where instance ToJSON AuthSalt where
toJSON salt = object (toHex salt) toJSON (AuthSalt bs) = (String . decodeUtf8 . B16.encode) bs
instance FromJSON AuthSalt instance FromJSON AuthSalt where
parseJSON = withText ""
(\t -> do
let enc = fst $ B16.decode $ encodeUtf8 t
return (AuthSalt enc)
)
newtype AuthHash = AuthHash ByteString deriving (Show)
instance ToJSON AuthHash where
toJSON (AuthHash bs) = (String . decodeUtf8 . B16.encode) bs
instance FromJSON AuthHash where
parseJSON = withText ""
(\t -> do
let enc = fst $ B16.decode $ encodeUtf8 t
return (AuthHash enc)
)
data AuthRequest = AuthRequest data AuthRequest = AuthRequest
{ requestUser :: Int { requestUser :: Int
, requestHash :: ByteString , requestHash :: AuthHash
} }
deriving (Show, Generic) deriving (Show, Generic)
instance ToJSON AuthRequest where instance ToJSON AuthRequest where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthRequest instance FromJSON AuthRequest
data AuthResult data AuthResult
= Granted = Granted
{ authToken :: ByteString { authToken :: AuthToken
} }
| Denied | Denied
deriving (Show, Generic) deriving (Show, Generic)
instance ToJSON AuthResult where instance ToJSON AuthResult where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthResult instance FromJSON AuthResult
newtype AuthToken = AuthToken ByteString deriving (Show)
instance ToJSON AuthToken where
toJSON (AuthToken bs) = (String . decodeUtf8 . B16.encode) bs
instance FromJSON AuthToken where
parseJSON = withText ""
(\t -> do
let enc = fst $ B16.decode $ encodeUtf8 t
return (AuthToken enc)
)