This commit is contained in:
nek0 2019-04-21 17:27:15 +02:00
parent 18ecc04eab
commit 5e873d5a37
10 changed files with 174 additions and 89 deletions

View file

@ -21,6 +21,7 @@ executable mateamt
, Model
, Model.User
, Model.Beverage
, Model.Auth
, Types
, Types.Auth
, Types.Beverage
@ -42,5 +43,8 @@ executable mateamt
, http-api-data
, bytestring
, base16-bytestring
, random-bytestring
, containers
, StateVar
hs-source-dirs: src
default-language: Haskell2010

View file

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

View file

@ -9,6 +9,8 @@ import Servant.Server.Experimental.Auth
import Data.Time.Clock
import Data.ByteString.Random
import Database.PostgreSQL.Simple
import Network.Wai
@ -34,6 +36,7 @@ main = do
"host='localhost' port=5432 dbname='mateamt' user='mateamt' password='mateamt'"
execute_ conn initUser
execute_ conn initBeverage
execute_ conn initToken
withStdoutLogger $ \log -> do
let settings = setPort 3000 $ setLogger log defaultSettings
runSettings settings (app conn)
@ -75,7 +78,8 @@ users conn =
userNew :: UserSubmit -> Handler Int
userNew us = liftIO $ do
now <- getCurrentTime
head <$> runInsert_ conn (insertUser us (utctDay now))
randSalt <- random 8
head <$> runInsert_ conn (insertUser us (utctDay now) randSalt)
userUpdate :: (Int, UserSubmit) -> Handler ()
userUpdate (id, us) = liftIO $ do
@ -86,4 +90,4 @@ users conn =
authGet = liftIO . getUserAuthInfo conn
authSend :: AuthRequest -> Handler AuthResult
authSend _ = pure $ Granted $ AuthToken "mockgrant"
authSend _ = liftIO $ Granted <$> AuthToken <$> random 8

View file

@ -4,3 +4,4 @@ module Model
import Model.User as M
import Model.Beverage as M
import Model.Auth as M

73
src/Model/Auth.hs Normal file
View file

@ -0,0 +1,73 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Model.Auth where
import GHC.Generics
import Control.Arrow ((<<<))
import Data.Profunctor.Product (p3)
import qualified Database.PostgreSQL.Simple as PGS
import Data.Text (Text)
import Data.Time.Calendar (Day)
import Data.ByteString (ByteString)
import Data.Maybe (fromMaybe)
import Opaleye
import qualified Opaleye.Constant as C
-- internal imports
import Types.Auth
import Model.User
initToken :: PGS.Query
initToken = "create table if not exists \"token\" (token_string bytea not null primary key, token_user integer not null, token_expiry timestamptz not null)"
tokenTable :: Table
( Field SqlBytea
, Field SqlInt4
, Field SqlTimestamptz
)
( Field SqlBytea
, Field SqlInt4
, Field SqlTimestamptz
)
tokenTable = table "token" (
p3
( tableField "token_string"
, tableField "token_user"
, tableField "token_expiry"
)
)
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) (toEnum $ fromMaybe 0 i9)
)
users

View file

@ -16,7 +16,7 @@ import GHC.Generics
import Opaleye as O
initBeverage :: PGS.Query
initBeverage = "create Table if not exists \"beverage\" (id serial primary key, ident varchar(128) not null, price integer not null, amount integer not null, vanish integer not null, ml integer not null, avatar integer, supplier integer, max_amount integer not null, total_bought integer not null, amount_per_crate integer not null, price_per_crate integer, art_nr varchar(128))"
initBeverage = "create Table if not exists \"beverage\" (beverage_id serial primary key, beverage_ident varchar(128) not null, beverage_price integer not null, beverage_amount integer not null, beverage_vanish integer not null, beverage_ml integer not null, beverage_avatar integer, beverage_supplier integer, beverage_max_amount integer not null, beverage_total_bought integer not null, beverage_amount_per_crate integer not null, beverage_price_per_crate integer, beverage_art_nr varchar(128))"
beverageTable :: Table
( Maybe (Field SqlInt4)
@ -49,18 +49,18 @@ beverageTable :: Table
)
beverageTable = table "beverage" (
p13
( tableField "id"
, tableField "ident"
, tableField "price"
, tableField "amount"
, tableField "vanish"
, tableField "ml"
, tableField "avatar"
, tableField "supplier"
, tableField "max_amount"
, tableField "total_bought"
, tableField "amount_per_crate"
, tableField "price_per_crate"
, tableField "art_nr"
( tableField "beverage_id"
, tableField "beverage_ident"
, tableField "beverage_price"
, tableField "beverage_amount"
, tableField "beverage_vanish"
, tableField "beverage_ml"
, tableField "beverage_avatar"
, tableField "beverage_supplier"
, tableField "beverage_max_amount"
, tableField "beverage_total_bought"
, tableField "beverage_amount_per_crate"
, tableField "beverage_price_per_crate"
, tableField "beverage_art_nr"
)
)

View file

@ -6,11 +6,13 @@ module Model.User where
import Data.Text as T hiding (head)
import Data.Time.Calendar
import Data.Time.Clock
import Data.Profunctor.Product (p9)
import Data.Maybe (fromJust, isJust, fromMaybe)
import Data.ByteString hiding (head)
import Data.ByteString.Random
import Data.Int (Int64)
@ -30,7 +32,7 @@ import Types.Refine
import Types.Auth
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, salt bytea not null, hash bytea, algo integer)"
initUser = "create table if not exists \"user\" (user_id serial primary key, user_ident varchar(128) not null, user_balance integer not null, user_timestamp date not null, user_email varchar(128), user_avatar integer, user_salt bytea not null, user_hash bytea, user_algo integer)"
userTable :: Table
( Maybe (Field SqlInt4)
@ -55,15 +57,15 @@ userTable :: Table
)
userTable = table "user" (
p9
( tableField "id"
, tableField "ident"
, tableField "balance"
, tableField "time_stamp"
, tableField "email"
, tableField "avatar"
, tableField "salt"
, tableField "hash"
, tableField "algo"
( tableField "user_id"
, tableField "user_ident"
, tableField "user_balance"
, tableField "user_timestamp"
, tableField "user_email"
, tableField "user_avatar"
, tableField "user_salt"
, tableField "user_hash"
, tableField "user_algo"
)
)
@ -102,33 +104,8 @@ userSelect conn ref sw = do
)
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) (toEnum $ fromMaybe 0 i9)
)
users
insertUser :: UserSubmit -> Day -> Insert [Int]
insertUser us now = Insert
insertUser :: UserSubmit -> Day -> ByteString -> Insert [Int]
insertUser us now randSalt = Insert
{ iTable = userTable
, iRows =
[
@ -138,7 +115,7 @@ insertUser us now = Insert
, C.constant now
, C.constant (userSubmitEmail us)
, C.constant (Nothing :: Maybe Int)
, C.constant ("mocksalt" :: ByteString)
, C.constant randSalt
, C.constant (Nothing :: Maybe ByteString)
, C.constant (Nothing :: Maybe Int)
)

View file

@ -5,5 +5,4 @@ module Types
import Types.Auth as T
import Types.Beverage as T
import Types.Refine as T
import Types.Token as T
import Types.User as T

View file

@ -10,21 +10,33 @@ import Data.Aeson
import Data.ByteString
import qualified Data.ByteString.Base16 as B16
import qualified Data.Set as S
import Data.Time.Clock (UTCTime)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.StateVar
import Data.IORef
import Control.Monad.IO.Class (liftIO)
-- internal imports
data AuthInfo = AuthInfo
{ authSalt :: AuthSalt
{ authSalt :: AuthSalt
, authAlgorithm :: AuthAlgorithm
, authTicket :: AuthTicket
}
deriving (Show, Generic)
instance ToJSON AuthInfo where
toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthInfo
data AuthAlgorithm
= PBKDF2
= SHA3_512
deriving (Show, Read, Generic, Enum)
instance ToJSON AuthAlgorithm where
@ -33,6 +45,18 @@ instance ToJSON AuthAlgorithm where
instance FromJSON AuthAlgorithm where
parseJSON j = read <$> parseJSON j
newtype AuthTicket = AuthTicket ByteString deriving (Show, Eq, Ord)
instance ToJSON AuthTicket where
toJSON (AuthTicket bs) = (String . decodeUtf8 . B16.encode) bs
instance FromJSON AuthTicket where
parseJSON = withText ""
(\t -> do
let enc = fst $ B16.decode $ encodeUtf8 t
return (AuthTicket enc)
)
newtype AuthSalt = AuthSalt ByteString deriving (Show)
instance ToJSON AuthSalt where
@ -58,8 +82,8 @@ instance FromJSON AuthHash where
)
data AuthRequest = AuthRequest
{ requestUser :: Int
, requestHash :: AuthHash
{ authRequestTicket :: AuthTicket
, authRequestHash :: AuthHash
}
deriving (Show, Generic)
@ -70,7 +94,7 @@ instance FromJSON AuthRequest
data AuthResult
= Granted
{ authToken :: AuthToken
{ authToken :: Token
}
| Denied
deriving (Show, Generic)
@ -78,8 +102,6 @@ data AuthResult
instance ToJSON AuthResult where
toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthResult
newtype AuthToken = AuthToken ByteString deriving (Show)
instance ToJSON AuthToken where
@ -91,3 +113,27 @@ instance FromJSON AuthToken where
let enc = fst $ B16.decode $ encodeUtf8 t
return (AuthToken enc)
)
data Token = Token
{ tokenString :: ByteString
, tokenUser :: Int
, tokenExpiry :: UTCTime
}
deriving (Generic, Show)
instance ToJSON Token where
toJSON (Token s _ _) = (String . decodeUtf8 . B16.encode) s
type TicketStore = StateVar (S.Set Ticket)
{-# NOINLINE ticketStore #-}
data Ticket = Ticket
{ ticketId :: AuthTicket
, ticketUser :: Int
, ticketExpiry :: UTCTime
}
deriving (Ord)
instance Eq Ticket where
(Ticket i1 _ _) == (Ticket i2 _ _) = i1 == i2

View file

@ -1,20 +0,0 @@
{-# LANGUAGE DeriveGeneric #-}
module Types.Token where
import GHC.Generics
import Data.Aeson
import Data.ByteString
import Data.Time.Clock (UTCTime)
data Token = Token
{ tokenString :: ByteString
, tokenUser :: Int
, tokenExpiry :: UTCTime
}
deriving (Generic, Show)
instance ToJSON Token where
toJSON (Token s _ _) = toJSON s