From 5e873d5a37a52b263241a2b3ddf43d07df317d46 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 21 Apr 2019 17:27:15 +0200 Subject: [PATCH] meow --- mateamt.cabal | 4 +++ shell.nix | 13 ++++---- src/Main.hs | 8 +++-- src/Model.hs | 1 + src/Model/Auth.hs | 73 +++++++++++++++++++++++++++++++++++++++++++ src/Model/Beverage.hs | 28 ++++++++--------- src/Model/User.hs | 53 +++++++++---------------------- src/Types.hs | 1 - src/Types/Auth.hs | 62 +++++++++++++++++++++++++++++++----- src/Types/Token.hs | 20 ------------ 10 files changed, 174 insertions(+), 89 deletions(-) create mode 100644 src/Model/Auth.hs delete mode 100644 src/Types/Token.hs diff --git a/mateamt.cabal b/mateamt.cabal index e826273..a990352 100644 --- a/mateamt.cabal +++ b/mateamt.cabal @@ -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 diff --git a/shell.nix b/shell.nix index 1c7e506..a68df48 100644 --- a/shell.nix +++ b/shell.nix @@ -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; diff --git a/src/Main.hs b/src/Main.hs index ea3bae7..81569ce 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/Model.hs b/src/Model.hs index 5b24a24..8a9000f 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -4,3 +4,4 @@ module Model import Model.User as M import Model.Beverage as M +import Model.Auth as M diff --git a/src/Model/Auth.hs b/src/Model/Auth.hs new file mode 100644 index 0000000..cccfe53 --- /dev/null +++ b/src/Model/Auth.hs @@ -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 diff --git a/src/Model/Beverage.hs b/src/Model/Beverage.hs index 5890607..3eb7237 100644 --- a/src/Model/Beverage.hs +++ b/src/Model/Beverage.hs @@ -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" ) ) diff --git a/src/Model/User.hs b/src/Model/User.hs index 3c9520b..b513276 100644 --- a/src/Model/User.hs +++ b/src/Model/User.hs @@ -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) ) diff --git a/src/Types.hs b/src/Types.hs index 041e38f..ab6dbda 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -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 diff --git a/src/Types/Auth.hs b/src/Types/Auth.hs index d835a60..767314c 100644 --- a/src/Types/Auth.hs +++ b/src/Types/Auth.hs @@ -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 diff --git a/src/Types/Token.hs b/src/Types/Token.hs deleted file mode 100644 index 55349d6..0000000 --- a/src/Types/Token.hs +++ /dev/null @@ -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