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
, http-api-data
, bytestring
, base16-bytestring
hs-source-dirs: src
default-language: Haskell2010

View file

@ -61,17 +61,29 @@ authHandler = mkAuthHandler handler
users :: Connection -> Server UserAPI
users conn =
userList :<|>
( userList :<|>
userNew :<|>
userUpdate
) :<|>
( authGet :<|>
authSend
)
where
userList :: Maybe Refine -> Bool -> Handler [User]
userList ref sw = liftIO $ userSelect conn ref sw
userNew :: UserSubmit -> Handler Int
userNew us = liftIO $ do
now <- getCurrentTime
head <$> runInsert_ conn (insertUser us (utctDay now))
userUpdate :: (Int, UserSubmit) -> Handler ()
userUpdate (id, us) = liftIO $ do
now <- getCurrentTime
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 #-}
module Model.User where
import Data.Text as T
import Data.Text as T hiding (head)
import Data.Time.Calendar
import Data.Time.Clock
import Data.Profunctor.Product (p7)
import Data.Profunctor.Product (p9)
import Data.Aeson
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
@ -26,6 +28,7 @@ import qualified Opaleye.Constant as C
-- internal imports
import Types.Refine
import Types.Auth
data User
= User
@ -35,7 +38,9 @@ data User
, userTimeStamp :: Day
, userEmail :: Maybe T.Text
, userAvatar :: Maybe Int
, userPin :: Maybe T.Text
, userSalt :: AuthSalt
, userHash :: Maybe AuthHash
, userAlgo :: Maybe Int
}
| QueryUser
{ userId :: Int
@ -45,7 +50,7 @@ data User
deriving (Generic, Show)
instance ToJSON User where
toEncoding (User id ident balance ts email avatar _) =
toEncoding (User id ident balance ts email avatar _ _ _) =
pairs
( "userId" .= id
<> "userIdent" .= ident
@ -66,7 +71,7 @@ instance FromJSON User
data UserSubmit = UserSubmit
{ userSubmitIdent :: T.Text
, userSubmitEmail :: Maybe T.Text
, userSubmitPin :: Maybe T.Text
--, userSubmitPin :: Maybe T.Text
}
deriving (Generic, Show)
@ -76,7 +81,7 @@ instance ToJSON UserSubmit where
instance FromJSON UserSubmit
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
( Maybe (Field SqlInt4)
@ -85,7 +90,9 @@ userTable :: Table
, Field SqlDate
, FieldNullable SqlText
, FieldNullable SqlInt4
, FieldNullable SqlText
, Field SqlBytea
, FieldNullable SqlBytea
, FieldNullable SqlInt4
)
( Field SqlInt4
, Field SqlText
@ -93,17 +100,21 @@ userTable :: Table
, Field SqlDate
, FieldNullable SqlText
, FieldNullable SqlInt4
, FieldNullable SqlText
, Field SqlBytea
, FieldNullable SqlBytea
, FieldNullable SqlInt4
)
userTable = table "user" (
p7
p9
( tableField "id"
, tableField "ident"
, tableField "balance"
, tableField "time_stamp"
, tableField "email"
, tableField "avatar"
, tableField "pin"
, tableField "salt"
, tableField "hash"
, tableField "algo"
)
)
@ -115,22 +126,58 @@ userSelect
userSelect conn ref sw = do
today <- utctDay <$> getCurrentTime
users <- runSelect conn (case ref of
Nothing -> keepWhen (\(_, _, _, ts, _, _, _) ->
Nothing -> keepWhen (\(_, _, _, ts, _, _, _, _, _) ->
ts .>= C.constant (addDays (-30) today)
) <<< queryTable userTable
Just All -> selectTable userTable
Just Old -> keepWhen (\(_, _, _, ts, _, _, _) ->
Just Old -> keepWhen (\(_, _, _, ts, _, _, _, _, _) ->
ts .<= C.constant (addDays (-30) today)
) <<< 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
(\(i1, i2, i3, i4, i5, i6, i7) -> return $
(\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> return $
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
)
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 us now = Insert
{ iTable = userTable
@ -142,26 +189,30 @@ insertUser us now = Insert
, C.constant now
, C.constant (userSubmitEmail us)
, 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
}
updateUser :: Int -> UserSubmit -> Day -> Update Int64
updateUser id us now = Update
{ uTable = userTable
, uUpdateWith = updateEasy (\(id_, _, i3, _, _, i6, _) ->
, uUpdateWith = updateEasy (\(id_, _, i3, _, _, i6, i7, i8, i9) ->
( id_
, C.constant (userSubmitIdent us)
, i3
, C.constant (now)
, C.constant (userSubmitEmail us)
, i6
, C.constant (userSubmitPin us)
, i7
, i8
, i9
)
)
, uWhere = (\(i1, _, _, _, _, _, _) -> i1 .== C.constant id)
, uWhere = (\(i1, _, _, _, _, _, _, _, _) -> i1 .== C.constant id)
, uReturning = rCount
}

View file

@ -1,6 +1,6 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Types.Auth where
import GHC.Generics
@ -8,6 +8,9 @@ import GHC.Generics
import Data.Aeson
import Data.ByteString
import qualified Data.ByteString.Base16 as B16
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
data AuthInfo = AuthInfo
{ authSalt :: AuthSalt
@ -22,23 +25,40 @@ instance FromJSON AuthInfo
data AuthAlgorithm
= PBKDF2
deriving (Show, Generic)
deriving (Show, Generic, Enum)
instance ToJSON AuthAlgorithm where
toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthAlgorithm
type AuthSalt = ByteString
newtype AuthSalt = AuthSalt ByteString deriving (Show)
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
{ requestUser :: Int
, requestHash :: ByteString
, requestHash :: AuthHash
}
deriving (Show, Generic)
@ -49,7 +69,7 @@ instance FromJSON AuthRequest
data AuthResult
= Granted
{ authToken :: ByteString
{ authToken :: AuthToken
}
| Denied
deriving (Show, Generic)
@ -58,3 +78,15 @@ instance ToJSON AuthResult where
toEncoding = genericToEncoding defaultOptions
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)
)