more touching

.gitignore

@@ -12,3 +12,5 @@ report.html
 *.save*
 .envrc
 .direnv/
+.hie/
+stan.html

app/AppTypes/Configuration.hs

@@ -20,6 +20,7 @@ data ServerConfig = ServerConfig
   -- , configMaxConnectionsPerClient :: Word
   -- , configBlockRegistration :: Bool
   , configSendmailPath      :: FilePath
+  , configJWTSecret         :: T.Text
   }
   deriving (Show)
 
@@ -37,6 +38,7 @@ instance FromJSON ServerConfig where
     -- <*> m .:? "max_connections_per_client" .!= 10
     -- <*> m .: "block_registration"
     <*> m .: "sendmail_path"
+    <*> m .: "jwt_secret"
   parseJSON _ = error "Can not parse configuration"
 
 data Options = Options

app/Main.hs

@@ -10,40 +10,47 @@ module Main where
 
 import Prelude as P
 
+import Crypto.JWT hiding (Context, header)
+
+import Control.Concurrent.STM.TVar
 import Control.Concurrent.STM (newTQueueIO)
 import Control.Concurrent (forkIO)
 
+import Control.Lens hiding (Context)
+
+import Control.Monad (void, unless)
+
+import Control.Monad.Reader
+
 import Servant
 import Servant.Server.Experimental.Auth
 import qualified Servant.OpenApi as OA
 import Servant.Swagger.UI
-import Servant.RawM
+import Servant.RawM.Server
 
 import Data.Set as S (empty)
+
+import qualified Data.ByteString.Lazy as B
 import Data.ByteString.Char8 as B8 hiding (putStrLn)
+
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+
 import Data.String
+
 import Data.Yaml
+
 import Data.Version (showVersion)
-import Data.IP
+
 import qualified Data.OpenApi as OA hiding (Server)
 
 import Database.PostgreSQL.Simple
 import Database.PostgreSQL.Simple.Migration
 import Database.PostgreSQL.Simple.Util
 
-import Network.Socket (defaultPort)
-
 import Network.Wai
 import Network.Wai.Logger
 import Network.Wai.Handler.Warp
-import Network.Wai.Middleware.Throttle
-
-import Control.Monad.Reader
-
-import Control.Concurrent.STM.TVar
-
-import Control.Lens hiding (Context)
 
 import Options.Applicative
 
@@ -87,6 +94,7 @@ main = do
         -- max_conn_per_client
         -- block_registration
         sendmail_path
+        jwt_secret
         ) -> do
           conn <- connectPostgreSQL (
             "host='" <> fromString (T.unpack db_host) <> "' " <>
@@ -142,22 +150,10 @@ main = do
                   , rsSoftwareVersion = T.pack (showVersion version)
                   , rsSendmailPath = sendmail_path
                   , rsMailQueue = mailQueue
+                  , rsJWTSecret =
+                    fromOctets . B.fromStrict $ TE.encodeUtf8 jwt_secret
                   }
-                expirationSpec = TimeSpec 5 0 -- five seconds
-                throt = (defaultThrottleSettings expirationSpec)
-                  { throttleSettingsRate   = 10
-                  , throttleSettingsPeriod = 1000
-                  }
-            th <- initCustomThrottler throt
-              (\req ->
-                let headers = requestHeaders req
-                in  case lookup "x-forwarded-for" headers of
-                      Just addrs ->
-                        let xaddr = fst (B8.break (== ',') addrs)
-                        in  Right $ Address $ toSockAddr (read (B8.unpack xaddr), defaultPort)
-                      Nothing -> Right $ Address $ remoteHost req
-                )
-            runSettings settings (throttle th (app initState))
+            runSettings settings (app initState)
   where
     opts = info (options <**> helper)
       ( fullDesc
@@ -168,7 +164,8 @@ main = do
 app :: ReadState -> Application
 -- app conn = serveWithContext userApi genAuthServerContext (users conn)
 app initState = 
-  serveWithContext combinedAPI (genAuthServerContext (rsConnection initState)) server
+  serveWithContext combinedAPI
+    (genAuthServerContext (rsJWTSecret initState) (rsConnection initState)) server
   where
     server :: Server CombinedAPI
     server = appToServer initState mateAPI thisApi :<|>
@@ -182,7 +179,6 @@ appToServer initState myApi =
 
 thisApi :: ServerT MateAPI MateHandler
 thisApi =
-  authGet :<|>
   authSend :<|>
   authLogout :<|>
 
@@ -246,21 +242,22 @@ authProxy :: Proxy '[ AuthHandler Request (Maybe (Int, AuthMethod)) ]
 authProxy = Proxy
 
 genAuthServerContext
-  :: Connection
+  :: JWK
+  -> Connection
   -> Context '[ AuthHandler Request (Maybe (Int, AuthMethod)) ]
-genAuthServerContext conn = authHandler conn Servant.:. EmptyContext
+genAuthServerContext key conn = authHandler key conn Servant.:. EmptyContext
 
 type instance AuthServerData (AuthProtect "header-auth") = Maybe (Int, AuthMethod)
 
-authHandler :: Connection -> AuthHandler Request (Maybe (Int, AuthMethod))
-authHandler conn = mkAuthHandler handler
+authHandler :: JWK -> Connection -> AuthHandler Request (Maybe (Int, AuthMethod))
+authHandler key conn = mkAuthHandler handler
   where
     handler :: Request -> Handler (Maybe (Int, AuthMethod))
     handler req = do
       let headers = requestHeaders req
-      case lookup "Authentication" headers of
-        Just hh ->
-          validateToken hh conn
+      case lookup "Authorization" headers of
+        Just hh -> do
+          validateToken (B8.drop 7 hh) key conn
         _       ->
           return Nothing
 
@@ -269,3 +266,6 @@ instance OA.HasOpenApi sub => OA.HasOpenApi (AuthProtect "header-auth" :> sub) w
 
 instance OA.HasOpenApi (RawM' Application) where
   toOpenApi _ = OA.toOpenApi (Proxy :: Proxy (Get '[JSON] NoContent))
+
+instance OA.HasOpenApi (JWS Identity () JWSHeader) where
+  toOpenApi _ = OA.toOpenApi (Proxy :: Proxy (Get '[JSON] NoContent))

cabal.project

@@ -1,4 +0,0 @@
--- index-state: 2021-02-05T00:00:00Z
-packages:
-  ./
-tests: true

config.yaml

@@ -10,3 +10,5 @@ currency: "meow"
 currency_fraction: 2
 #block_registration: false
 sendmail_path: "/run/wrappers/bin/sendmail"
+# Change me !!!
+jwt_secret: "MySuperDuperSecretJWTKeyChangeMe"

flake.lock

@@ -0,0 +1,60 @@
+{
+  "nodes": {
+    "flake-utils": {
+      "inputs": {
+        "systems": "systems"
+      },
+      "locked": {
+        "lastModified": 1710146030,
+        "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "type": "github"
+      }
+    },
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1725059563,
+        "narHash": "sha256-laJvLHrSU5M9zWlejH7H67HdpLhcUI6uPDa4rX7eUuE=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "0abfc619bcb605299a0f3f01c1887bb65db61a6b",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "root": {
+      "inputs": {
+        "flake-utils": "flake-utils",
+        "nixpkgs": "nixpkgs"
+      }
+    },
+    "systems": {
+      "locked": {
+        "lastModified": 1681028828,
+        "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+        "owner": "nix-systems",
+        "repo": "default",
+        "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+        "type": "github"
+      },
+      "original": {
+        "owner": "nix-systems",
+        "repo": "default",
+        "type": "github"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}

flake.nix

@@ -0,0 +1,44 @@
+{
+  description = "A game stub written in Haskell";
+
+  inputs = {
+    nixpkgs.url = "github:NixOS/nixpkgs";
+    flake-utils.url = "github:numtide/flake-utils";
+  };
+
+  outputs = { self, nixpkgs, flake-utils }:
+    flake-utils.lib.eachDefaultSystem (system:
+      let
+        pkgs = nixpkgs.legacyPackages.${system};
+
+        haskellPackages = pkgs.haskellPackages.override {
+          overrides = final: prev: {
+            openapi3 = jailbreakUnbreak (pkgs.haskell.lib.dontCheck prev.openapi3);
+          };
+        };
+
+        jailbreakUnbreak = pkg:
+          pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; }));
+
+        packageName = "mateamt";
+      in rec {
+        packages.${packageName} = # (ref:haskell-package-def)
+          haskellPackages.callCabal2nix packageName self rec {
+            # Dependency overrides go here
+            postgresql-simple-migration = jailbreakUnbreak haskellPackages.postgresql-simple-migration;
+          };
+
+        defaultPackage = self.packages.${system}.${packageName};
+
+        devShell = haskellPackages.shellFor {
+          packages = p: [ defaultPackage ];
+          withHoogle = true;
+          buildInputs = with haskellPackages; [
+            haskell-language-server
+            ghcid
+            cabal-install
+          ];
+        };
+      });
+}
+

mateamt.cabal

@@ -72,10 +72,22 @@ library
 
   -- Modules included in this library but not exported.
   -- other-modules:
+  default-extensions:
+    StrictData
   other-extensions:
-    DataKinds TypeOperators FlexibleInstances MultiParamTypeClasses
-    RankNTypes ScopedTypeVariables FlexibleContexts OverloadedStrings
-    Arrows CPP LambdaCase DeriveGeneric TypeFamilies
+    DataKinds
+    TypeOperators
+    FlexibleInstances
+    MultiParamTypeClasses
+    RankNTypes
+    ScopedTypeVariables
+    FlexibleContexts
+    OverloadedStrings
+    Arrows
+    CPP
+    LambdaCase
+    DeriveGeneric
+    TypeFamilies
     TypeSynonymInstances
 
   build-depends:
@@ -93,7 +105,6 @@ library
     , servant
     , servant-server
     , servant-openapi3
-    , servant-rawm >= 0.3.0.0
     , servant-rawm-server
     , opaleye
     , aeson
@@ -111,10 +122,14 @@ library
     , haskell-gettext
     , mime-mail
     , directory
+    , jose >= 0.10
+    , monad-time
 
   hs-source-dirs:   src
   default-language: Haskell2010
   ghc-options:      -Wall
+                    -fwrite-ide-info
+                    -hiedir=.hie
 
 executable mateamt
   main-is:          Main.hs
@@ -125,6 +140,8 @@ executable mateamt
     AppTypes.Configuration
     Janitor
     Paths_mateamt
+  default-extensions:
+    StrictData
   other-extensions:
     DataKinds TypeOperators FlexibleInstances MultiParamTypeClasses
     RankNTypes ScopedTypeVariables FlexibleContexts OverloadedStrings
@@ -149,24 +166,27 @@ executable mateamt
     , network
     , servant
     , servant-server
-    , servant-rawm
+    , servant-rawm-server
     , servant-openapi3
     , servant-swagger-ui
     , servant-swagger-ui-core
     , warp
     , wai
     , wai-logger
-    , wai-middleware-throttle
     , yaml
     , optparse-applicative
     , case-insensitive
     , iproute
     , clock
     , tagged
+    , jose >= 0.10
+    , aeson
 
   hs-source-dirs:   app
   default-language: Haskell2010
   ghc-options:      -Wall
+                    -fwrite-ide-info
+                    -hiedir=.hie
 
 -- test-suite mateamt-test
 --   default-language: Haskell2010

src/API.hs

@@ -13,16 +13,14 @@ import Servant.Server
 
 import Data.Proxy
 
-import Servant.RawM
-import Servant.RawM.Server ()
+import Servant.RawM.Server
 
 -- internal imports
 
 import Types
 
 type MateAPI = "v1" :> (
-  "auth" :> "get" :> ReqBody '[JSON] TicketRequest :> Post '[JSON] AuthInfo
-  :<|> "auth" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] AuthResult
+  "auth" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] String
   :<|> "auth" :> AuthProtect "header-auth" :> Delete '[JSON] NoContent
 
   :<|> "auth" :> "manage" :> AuthProtect "header-auth"
@@ -98,7 +96,6 @@ type MateAPI = "v1" :> (
   :<|> "meta" :> Get '[JSON] MetaInformation
   )
 
-authGetLink :: Link
 authSendLink :: Link
 authLogoutLink :: Link
 
@@ -126,7 +123,7 @@ journalShowLink :: Maybe Int -> Maybe Int -> Link
 journalPostCheck :: Link
 
 avatarGetLink :: Int -> Link
-avaterInsertLink :: Link
+avatarInsertLink :: Link
 avatarUpdateLink :: Int -> Link
 avatarListLink :: Link
 
@@ -139,12 +136,11 @@ roleAssociationSubmitLink :: Link
 roleAssociationDeleteLink :: Link
 
 settingsGetLink :: Link
-settingsUpdateLnk :: Link
+settingsUpdateLink :: Link
 
 metaGetLink :: Link
 
-( authGetLink :<|>
-  authSendLink :<|>
+( authSendLink :<|>
   authLogoutLink :<|>
 
   authManageListLink :<|>
@@ -171,7 +167,7 @@ metaGetLink :: Link
   journalPostCheck :<|>
 
   avatarGetLink :<|>
-  avaterInsertLink :<|>
+  avatarInsertLink :<|>
   avatarUpdateLink :<|>
   avatarListLink :<|>
 
@@ -184,7 +180,7 @@ metaGetLink :: Link
   roleAssociationDeleteLink :<|>
 
   settingsGetLink :<|>
-  settingsUpdateLnk :<|>
+  settingsUpdateLink :<|>
 
   metaGetLink
   ) = allLinks (Proxy :: Proxy MateAPI)

src/Control/Auth.hs

@@ -3,6 +3,8 @@ module Control.Auth where
 
 import Servant
 
+import Control.Lens (re, view, review)
+
 import Control.Monad (void)
 
 import Control.Monad.Reader (asks)
@@ -10,8 +12,14 @@ import Control.Monad.IO.Class (liftIO)
 
 import Control.Concurrent.STM (readTVarIO)
 
-import Crypto.KDF.Argon2
 import Crypto.Error
+import Crypto.JWT (SignedJWT, encodeCompact, base64url)
+import Crypto.KDF.Argon2
+
+import Data.Aeson (encode)
+
+import qualified Data.ByteString.Char8 as B8
+import qualified Data.ByteString.Lazy as BL
 
 import Data.String (fromString)
 
@@ -32,11 +40,8 @@ authGet (TicketRequest uid method) =
 
 authSend
   :: AuthRequest
-  -> MateHandler AuthResult
-authSend req = uncurry (processAuthRequest req) =<< ((,) <$>
-  (liftIO . readTVarIO =<< asks rsTicketStore) <*>
-  asks rsConnection
-  )
+  -> MateHandler String
+authSend req = B8.unpack . BL.toStrict . encodeCompact <$> (processAuthRequest req =<< asks rsConnection)
 
 authLogout
   :: Maybe (Int, AuthMethod)

src/Control/Meta.hs

@@ -11,8 +11,10 @@ metaGet :: MateHandler MetaInformation
 metaGet = do
   symbol <- asks rsCurrencySymbol
   version <- asks rsSoftwareVersion
+  decimals <- asks rsCurrencyFraction
   return (MetaInformation
     { metaInfoVersion = version
     , metaInfoCurrency = symbol
+    , metaInfoDecimals = fromIntegral decimals
     }
     )

src/Control/Settings.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Control.Settings where
 
+import Control.Monad (void, unless)
+
 import Control.Monad.Reader
 
 import Servant

src/Model/Auth.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 module Model.Auth where
 
 import Servant
@@ -17,7 +18,14 @@ import Control.Monad.Reader (asks)
 import Control.Concurrent (threadDelay)
 import Control.Concurrent.STM
 
+import Control.Lens
+
 import Crypto.Error
+import Crypto.JWT
+
+import qualified Data.Aeson as A
+
+import Data.ByteString as B (ByteString, fromStrict)
 
 import Data.Profunctor.Product (p4, p6)
 
@@ -34,9 +42,6 @@ import qualified Data.Set as S
 
 import Data.Time.Clock
 
-import Data.ByteString as B (ByteString)
-import Data.ByteString.Base64 (encode)
-
 import Opaleye hiding (null)
 
 -- internal imports
@@ -49,7 +54,7 @@ import Util.Crypto
 initToken :: PGS.Query
 initToken = mconcat
   [ "CREATE TABLE IF NOT EXISTS \"token\" ("
-  , "token_string BYTEA       NOT NULL PRIMARY KEY,"
+  , "token_id     SERIAL      PRIMARY KEY,"
   , "token_user   INTEGER     REFERENCES \"user\"(user_id) NOT NULL,"
   , "token_expiry TIMESTAMPTZ NOT NULL,"
   , "token_method INT         NOT NULL"
@@ -57,19 +62,19 @@ initToken = mconcat
   ]
 
 tokenTable :: Table
-  ( Field SqlBytea
+  ( Maybe (Field SqlInt4)
   , Field SqlInt4
   , Field SqlTimestamptz
   , Field SqlInt4
   )
-  ( Field SqlBytea
+  ( Field SqlInt4
   , Field SqlInt4
   , Field SqlTimestamptz
   , Field SqlInt4
   )
 tokenTable = table "token" (
   p4
-    ( tableField "token_string"
+    ( tableField "token_id"
     , tableField "token_user"
     , tableField "token_expiry"
     , tableField "token_method"
@@ -214,22 +219,31 @@ deleteAuthDataById adid conn = liftIO $ runDelete_ conn $ Delete
 
 validateToken
   :: ByteString
+  -> JWK
   -> PGS.Connection
   -> Handler (Maybe (Int, AuthMethod))
-validateToken header conn = do
+validateToken authHeader key conn = do
+  token <- either (error . show) id <$> liftIO (runJOSE $ do
+    jwt <- (decodeCompact (fromStrict authHeader) :: JOSE JWTError IO SignedJWT)
+    liftIO $ print jwt
+    let chk = defaultJWTValidationSettings (const True)
+    verifyJWT chk key jwt :: JOSE JWTError IO AuthResult
+    )
   tokens <- liftIO $ map fromDatabase <$> runSelect conn (
     proc () -> do
-      stuff@(tstr, _, _, _) <- (selectTable tokenTable) -< ()
-      restrict -< toFields header .== tstr
+      stuff@(_, tUser, _, tMethod) <- (selectTable tokenTable) -< ()
+      restrict -<
+        toFields (authUser token) .== tUser .&&
+        toFields (fromEnum $ authMethod token) .== tMethod
       returnA -< stuff
     )
   case tokens of
-    [Token _ uid stamp method] -> do
+    [Token tid uid stamp method] -> do
       now_ <- liftIO getCurrentTime
       if diffUTCTime stamp now_ > 0
       then return $ Just (uid, method)
       else do
-        void $ deleteToken header conn
+        void $ deleteToken tid conn
         liftIO $ threadDelay delayTime
         throwError $ err401
           { errBody = "Your token expired!"
@@ -242,11 +256,12 @@ validateToken header conn = do
 
 
 generateToken
-  :: Ticket
+  :: Int
+  -> AuthMethod
   -> AuthResponse
   -> PGS.Connection
-  -> MateHandler AuthResult
-generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do
+  -> MateHandler SignedJWT
+generateToken tuid method (AuthResponse response) conn = do
   authData <- liftIO $ map fromDatabase <$> runSelect conn (
     proc () -> do
       stuff@(_, auid, amethod, _, _, _) <- selectTable authDataTable -< ()
@@ -263,15 +278,22 @@ generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do
   -- liftIO $ print (response : userPayloads)
   if authResult
   then do
-    token <- liftIO $ Token
-      <$> (decodeUtf8 <$> randomString)
-      <*> pure tuid
-      <*> (addUTCTime (23*60) <$> getCurrentTime)
-      <*> pure method
-    void $ insertToken token conn
-    return $ Granted (AuthToken $ tokenString token)
+    key <- asks rsJWTSecret
+    issuedAt <- liftIO getCurrentTime
+    let preToken =
+          ( tuid
+          , (addUTCTime (23*60) issuedAt)
+          , method
+          )
+    liftIO $ print $ A.encode key
+    void $ insertToken preToken conn
+    let result = AuthResult issuedAt tuid method -- (AuthToken $ tokenString token)
+    signedJWT <- liftIO $ runJOSE (do
+      algo <- (bestJWSAlg key :: JOSE JWTError IO Alg)
+      signJWT key (newJWSHeader ((), algo)) result)
+    return $ either (error "Signing JWT failed") id signedJWT
   else
-    return Denied
+    throwError err401
   where
     validatePass resp =
       foldM
@@ -287,37 +309,39 @@ generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do
           )
         False
     validateChallengeResponse _ _ =
-      error "Validation of challenge response authentication not yet implemented"
+      throwError err501
+        { errBody = "Validation of challenge response authentication not yet implemented"
+        }
 
 
 insertToken
-  :: Token
+  :: (Int, UTCTime, AuthMethod)
   -> PGS.Connection
-  -> MateHandler ByteString
-insertToken (Token tString tUser tExpiry tMethod) conn =
+  -> MateHandler Int
+insertToken (tUser, tExpiry, tMethod) conn =
   fmap head $ liftIO $ runInsert_ conn $ Insert
     { iTable = tokenTable
     , iRows =
       [
-      ( toFields (encodeUtf8 tString)
+      ( toFields (Nothing :: Maybe Int)
       , toFields tUser
       , toFields tExpiry
       , toFields (fromEnum tMethod)
       )
       ]
-    , iReturning = rReturning (\(ident, _, _, _) -> ident)
+    , iReturning = rReturning (\(tid, _, _, _) -> tid)
     , iOnConflict = Nothing
     }
 
 
 deleteToken
-  :: ByteString
+  :: Int
   -> PGS.Connection
   -> Handler Int64
-deleteToken tstr conn =
+deleteToken dtid conn =
   liftIO $ runDelete_ conn $ Delete
     { dTable     = tokenTable
-    , dWhere     = \(rtstr, _, _, _) -> rtstr .== toFields tstr
+    , dWhere     = \(tid, _,  _, _) -> tid .== toFields dtid
     , dReturning = rCount
     }
 
@@ -364,25 +388,14 @@ newTicket ident method = do
 
 processAuthRequest
   :: AuthRequest
-  -> S.Set Ticket
   -> PGS.Connection
-  -> MateHandler AuthResult
-processAuthRequest (AuthRequest aticket pass) store conn = do
-  let mticket = S.filter (\st -> ticketId st == aticket) store
-  case S.toList mticket of
-    [ticket] -> do
+  -> MateHandler SignedJWT
+processAuthRequest (AuthRequest user method pass) conn = do
   -- liftIO $ putStrLn "there is a ticket..."
   now_ <- liftIO getCurrentTime
   liftIO $ threadDelay delayTime
-      if now_ > ticketExpiry ticket
-      then
-        return Denied
-      else
   -- liftIO $ putStrLn "...and it is valid"
-        generateToken ticket pass conn
-    _        -> do
-      liftIO $ threadDelay delayTime
-      return Denied
+  generateToken user method pass conn
 
 processLogout
   :: Int

src/Model/Settings.hs

@@ -25,7 +25,7 @@ initSettings :: PGS.Query
 initSettings = mconcat
   [ "CREATE TABLE IF NOT EXISTS \"settings\" ("
   , "settings_signup_blocked BOOLEAN NOT NULL DEFAULT false,"
-  , "settings_imprint        TEXT             DEFAULT \'\'"
+  , "settings_imprint        TEXT             DEFAULT \'\',"
   , "settings_idle_time      INTEGER NOT NULL DEFAULT 30"
   , ");"
   , "INSERT INTO \"settings\" DEFAULT VALUES"

src/Types/Auth.hs

@@ -1,10 +1,14 @@
 {-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
 module Types.Auth where
 
 import GHC.Generics
 
+import Control.Lens.Lens
+
+import Crypto.JWT
+
 import Data.Aeson
 
 import qualified Data.Set as S
@@ -109,7 +113,8 @@ instance FromJSON AuthResponse
 instance ToSchema AuthResponse
 
 data AuthRequest = AuthRequest
-  { authRequestTicket   :: AuthTicket
+  { authRequestUser     :: Int
+  , authRequestMethod   :: AuthMethod
   , authRequestPassword :: AuthResponse
   }
   deriving (Show, Generic)
@@ -120,11 +125,12 @@ instance ToJSON AuthRequest where
 instance FromJSON AuthRequest
 instance ToSchema AuthRequest
 
-data AuthResult
-  = Granted
-    { authToken :: AuthToken
+data AuthResult = AuthResult
+  { authTime   :: UTCTime
+  , authUser   :: Int
+  , authMethod :: AuthMethod
+  -- , authToken  :: AuthToken
   }
-  | Denied
   deriving (Show, Generic)
 
 instance ToJSON AuthResult where
@@ -132,6 +138,11 @@ instance ToJSON AuthResult where
 
 instance FromJSON AuthResult
 instance ToSchema AuthResult
+instance HasClaimsSet AuthResult where
+  claimsSet = lens (const emptyClaimsSet) const
+
+instance FromJSON Token
+instance ToSchema Token
 
 newtype AuthToken = AuthToken T.Text deriving (Show, Generic)
 
@@ -142,7 +153,7 @@ instance FromJSON AuthToken
 instance ToSchema AuthToken
 
 data Token = Token
-  { tokenString :: T.Text
+  { tokenId     :: Int
   , tokenUser   :: Int
   , tokenExpiry :: UTCTime
   , tokenMethod :: AuthMethod
@@ -158,12 +169,12 @@ data Token = Token
 
 instance DatabaseRepresentation Token where
 
-  type Representation Token = (ByteString, Int, UTCTime, Int)
+  type Representation Token = (Int, Int, UTCTime, Int)
 
 instance FromDatabase Token where
 
-  fromDatabase (string, usr, expiry, method) =
-    Token (decodeUtf8 string) usr expiry (toEnum method)
+  fromDatabase (tId, usr, expiry, method) =
+    Token tId usr expiry (toEnum method)
 
 
 type TicketStore = TVar (S.Set Ticket)

src/Types/Reader.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
 module Types.Reader where
 
 import qualified Data.Text as T
@@ -5,7 +7,11 @@ import qualified Data.Text as T
 import Servant (Handler)
 
 import Control.Concurrent.STM (TQueue)
+import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Reader (ReaderT)
+import Control.Monad.Time
+
+import Crypto.JOSE.JWK
 
 import Database.PostgreSQL.Simple (Connection)
 
@@ -23,6 +29,10 @@ data ReadState = ReadState
   , rsSoftwareVersion  :: T.Text
   , rsSendmailPath     :: FilePath
   , rsMailQueue        :: TQueue Mail
+  , rsJWTSecret        :: JWK
   }
 
 type MateHandler = ReaderT ReadState Handler
+
+instance MonadTime MateHandler where
+  currentTime = liftIO currentTime

src/Util.hs

@@ -72,6 +72,7 @@ initDB conn = do
   void $ execute_ conn initJournal
   void $ execute_ conn initRole
   void $ execute_ conn initUserToRole
+  void $ execute_ conn initSettings
   void $ runInsertInitialRoles conn
 
 -- This is only a dummy function.

test/AppMainSpec.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
 module AppMainSpec where
 
 import Database.PostgreSQL.Transact
@@ -9,11 +10,11 @@ import Control.Monad.IO.Class (liftIO)
 
 -- internal imports
 
-import Util
+import qualified "mateamt" Util as LibUtil
 import TestUtil
 
 spec :: Spec
 spec = describeDB (const $ return ()) "Initialize DB" $
-  itDB "calls initialization script" $ do
+  itDB "call initialization script" $ do
     conn <- getConnection
-    liftIO $ shouldReturn (initDB conn) ()
+    liftIO $ shouldReturn (LibUtil.initDB conn) ()

test/TestMain.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE PackageImports #-}
 module Main where
 
 import Test.Hspec