meow

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

shell.nix

@@ -4,9 +4,10 @@ let
 
   inherit (nixpkgs) pkgs;
 
-  f = { mkDerivation, aeson, base, bytestring, http-api-data
+  f = { mkDerivation, aeson, base, base16-bytestring, bytestring
-      , opaleye, postgresql-simple, product-profunctors, servant
+      , http-api-data, opaleye, postgresql-simple, product-profunctors
-      , servant-server, stdenv, text, time, wai, wai-logger, warp
+      , 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
+          aeson base base16-bytestring bytestring http-api-data opaleye
-          product-profunctors servant servant-server text time wai wai-logger
+          postgresql-simple product-profunctors random-bytestring servant
-          warp
+          servant-server text time wai wai-logger warp
         ];
         description = "A whole new matemat";
         license = stdenv.lib.licenses.agpl3;

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

src/Model.hs

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

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

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 "beverage_id"
-    , tableField "ident"
+    , tableField "beverage_ident"
-    , tableField "price"
+    , tableField "beverage_price"
-    , tableField "amount"
+    , tableField "beverage_amount"
-    , tableField "vanish"
+    , tableField "beverage_vanish"
-    , tableField "ml"
+    , tableField "beverage_ml"
-    , tableField "avatar"
+    , tableField "beverage_avatar"
-    , tableField "supplier"
+    , tableField "beverage_supplier"
-    , tableField "max_amount"
+    , tableField "beverage_max_amount"
-    , tableField "total_bought"
+    , tableField "beverage_total_bought"
-    , tableField "amount_per_crate"
+    , tableField "beverage_amount_per_crate"
-    , tableField "price_per_crate"
+    , tableField "beverage_price_per_crate"
-    , tableField "art_nr"
+    , tableField "beverage_art_nr"
     )
   )

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 "user_id"
-    , tableField "ident"
+    , tableField "user_ident"
-    , tableField "balance"
+    , tableField "user_balance"
-    , tableField "time_stamp"
+    , tableField "user_timestamp"
-    , tableField "email"
+    , tableField "user_email"
-    , tableField "avatar"
+    , tableField "user_avatar"
-    , tableField "salt"
+    , tableField "user_salt"
-    , tableField "hash"
+    , tableField "user_hash"
-    , tableField "algo"
+    , tableField "user_algo"
     )
   )
 
@@ -102,33 +104,8 @@ userSelect conn ref sw = do
       )
     users
 
-getUserAuthInfo
+insertUser :: UserSubmit -> Day -> ByteString -> Insert [Int]
-  :: PGS.Connection
+insertUser us now randSalt = Insert
-  -> 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
   { 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)
     )

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

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
+  { authRequestTicket :: AuthTicket
-  , requestHash :: AuthHash
+  , 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

src/Types/Token.hs

@@ -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