git vomit
This commit is contained in:
parent
8967cdfdea
commit
961fab0c88
4 changed files with 131 additions and 35 deletions
|
|
@ -39,5 +39,6 @@ executable mateamt
|
|||
, wai-logger
|
||||
, http-api-data
|
||||
, bytestring
|
||||
, base16-bytestring
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
18
src/Main.hs
18
src/Main.hs
|
|
@ -61,17 +61,29 @@ authHandler = mkAuthHandler handler
|
|||
|
||||
users :: Connection -> Server UserAPI
|
||||
users conn =
|
||||
userList :<|>
|
||||
userNew :<|>
|
||||
userUpdate
|
||||
( 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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -16,45 +19,74 @@ data AuthInfo = AuthInfo
|
|||
deriving (Show, Generic)
|
||||
|
||||
instance ToJSON AuthInfo where
|
||||
toEncoding = genericToEncoding defaultOptions
|
||||
toEncoding = genericToEncoding defaultOptions
|
||||
|
||||
instance FromJSON AuthInfo
|
||||
|
||||
data AuthAlgorithm
|
||||
= PBKDF2
|
||||
deriving (Show, Generic)
|
||||
deriving (Show, Generic, Enum)
|
||||
|
||||
instance ToJSON AuthAlgorithm where
|
||||
toEncoding = genericToEncoding defaultOptions
|
||||
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)
|
||||
|
||||
instance ToJSON AuthRequest where
|
||||
toEncoding = genericToEncoding defaultOptions
|
||||
toEncoding = genericToEncoding defaultOptions
|
||||
|
||||
instance FromJSON AuthRequest
|
||||
|
||||
data AuthResult
|
||||
= Granted
|
||||
{ authToken :: ByteString
|
||||
{ authToken :: AuthToken
|
||||
}
|
||||
| Denied
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance ToJSON AuthResult where
|
||||
toEncoding = genericToEncoding defaultOptions
|
||||
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)
|
||||
)
|
||||
|
|
|
|||
Loading…
Reference in a new issue