disable test suite

.gitignore

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

app/AppTypes/Configuration.hs

@@ -20,7 +20,6 @@ data ServerConfig = ServerConfig
   -- , configMaxConnectionsPerClient :: Word
   -- , configBlockRegistration :: Bool
   , configSendmailPath      :: FilePath
-  , configJWTSecret         :: T.Text
   }
   deriving (Show)
 
@@ -38,7 +37,6 @@ 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,47 +10,40 @@ 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.Server
+import Servant.RawM
 
 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
 
@@ -94,7 +87,6 @@ main = do
         -- max_conn_per_client
         -- block_registration
         sendmail_path
-        jwt_secret
         ) -> do
           conn <- connectPostgreSQL (
             "host='" <> fromString (T.unpack db_host) <> "' " <>
@@ -150,10 +142,22 @@ main = do
                   , rsSoftwareVersion = T.pack (showVersion version)
                   , rsSendmailPath = sendmail_path
                   , rsMailQueue = mailQueue
-                  , rsJWTSecret =
-                    fromOctets . B.fromStrict $ TE.encodeUtf8 jwt_secret
                   }
-            runSettings settings (app initState)
+                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))
   where
     opts = info (options <**> helper)
       ( fullDesc
@@ -164,8 +168,7 @@ main = do
 app :: ReadState -> Application
 -- app conn = serveWithContext userApi genAuthServerContext (users conn)
 app initState = 
-  serveWithContext combinedAPI
+  serveWithContext combinedAPI (genAuthServerContext (rsConnection initState)) server
-    (genAuthServerContext (rsJWTSecret initState) (rsConnection initState)) server
   where
     server :: Server CombinedAPI
     server = appToServer initState mateAPI thisApi :<|>
@@ -179,6 +182,7 @@ appToServer initState myApi =
 
 thisApi :: ServerT MateAPI MateHandler
 thisApi =
+  authGet :<|>
   authSend :<|>
   authLogout :<|>
 
@@ -242,22 +246,21 @@ authProxy :: Proxy '[ AuthHandler Request (Maybe (Int, AuthMethod)) ]
 authProxy = Proxy
 
 genAuthServerContext
-  :: JWK
+  :: Connection
-  -> Connection
   -> Context '[ AuthHandler Request (Maybe (Int, AuthMethod)) ]
-genAuthServerContext key conn = authHandler key conn Servant.:. EmptyContext
+genAuthServerContext conn = authHandler conn Servant.:. EmptyContext
 
 type instance AuthServerData (AuthProtect "header-auth") = Maybe (Int, AuthMethod)
 
-authHandler :: JWK -> Connection -> AuthHandler Request (Maybe (Int, AuthMethod))
+authHandler :: Connection -> AuthHandler Request (Maybe (Int, AuthMethod))
-authHandler key conn = mkAuthHandler handler
+authHandler conn = mkAuthHandler handler
   where
     handler :: Request -> Handler (Maybe (Int, AuthMethod))
     handler req = do
       let headers = requestHeaders req
-      case lookup "Authorization" headers of
+      case lookup "Authentication" headers of
-        Just hh -> do
+        Just hh ->
-          validateToken (B8.drop 7 hh) key conn
+          validateToken hh conn
         _       ->
           return Nothing
 
@@ -266,6 +269,3 @@ 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

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

config.yaml

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

flake.lock

@@ -1,60 +0,0 @@
-{
-  "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

@@ -1,44 +0,0 @@
-{
-  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,22 +72,10 @@ library
 
   -- Modules included in this library but not exported.
   -- other-modules:
-  default-extensions:
-    StrictData
   other-extensions:
-    DataKinds
+    DataKinds TypeOperators FlexibleInstances MultiParamTypeClasses
-    TypeOperators
+    RankNTypes ScopedTypeVariables FlexibleContexts OverloadedStrings
-    FlexibleInstances
+    Arrows CPP LambdaCase DeriveGeneric TypeFamilies
-    MultiParamTypeClasses
-    RankNTypes
-    ScopedTypeVariables
-    FlexibleContexts
-    OverloadedStrings
-    Arrows
-    CPP
-    LambdaCase
-    DeriveGeneric
-    TypeFamilies
     TypeSynonymInstances
 
   build-depends:
@@ -105,6 +93,7 @@ library
     , servant
     , servant-server
     , servant-openapi3
+    , servant-rawm >= 0.3.0.0
     , servant-rawm-server
     , opaleye
     , aeson
@@ -122,14 +111,10 @@ 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
@@ -140,8 +125,6 @@ executable mateamt
     AppTypes.Configuration
     Janitor
     Paths_mateamt
-  default-extensions:
-    StrictData
   other-extensions:
     DataKinds TypeOperators FlexibleInstances MultiParamTypeClasses
     RankNTypes ScopedTypeVariables FlexibleContexts OverloadedStrings
@@ -166,27 +149,24 @@ executable mateamt
     , network
     , servant
     , servant-server
-    , servant-rawm-server
+    , servant-rawm
     , 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,14 +13,16 @@ import Servant.Server
 
 import Data.Proxy
 
-import Servant.RawM.Server
+import Servant.RawM
+import Servant.RawM.Server ()
 
 -- internal imports
 
 import Types
 
 type MateAPI = "v1" :> (
-  "auth" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] String
+  "auth" :> "get" :> ReqBody '[JSON] TicketRequest :> Post '[JSON] AuthInfo
+  :<|> "auth" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] AuthResult
   :<|> "auth" :> AuthProtect "header-auth" :> Delete '[JSON] NoContent
 
   :<|> "auth" :> "manage" :> AuthProtect "header-auth"
@@ -96,6 +98,7 @@ type MateAPI = "v1" :> (
   :<|> "meta" :> Get '[JSON] MetaInformation
   )
 
+authGetLink :: Link
 authSendLink :: Link
 authLogoutLink :: Link
 
@@ -123,7 +126,7 @@ journalShowLink :: Maybe Int -> Maybe Int -> Link
 journalPostCheck :: Link
 
 avatarGetLink :: Int -> Link
-avatarInsertLink :: Link
+avaterInsertLink :: Link
 avatarUpdateLink :: Int -> Link
 avatarListLink :: Link
 
@@ -136,11 +139,12 @@ roleAssociationSubmitLink :: Link
 roleAssociationDeleteLink :: Link
 
 settingsGetLink :: Link
-settingsUpdateLink :: Link
+settingsUpdateLnk :: Link
 
 metaGetLink :: Link
 
-( authSendLink :<|>
+( authGetLink :<|>
+  authSendLink :<|>
   authLogoutLink :<|>
 
   authManageListLink :<|>
@@ -167,7 +171,7 @@ metaGetLink :: Link
   journalPostCheck :<|>
 
   avatarGetLink :<|>
-  avatarInsertLink :<|>
+  avaterInsertLink :<|>
   avatarUpdateLink :<|>
   avatarListLink :<|>
 
@@ -180,7 +184,7 @@ metaGetLink :: Link
   roleAssociationDeleteLink :<|>
 
   settingsGetLink :<|>
-  settingsUpdateLink :<|>
+  settingsUpdateLnk :<|>
 
   metaGetLink
   ) = allLinks (Proxy :: Proxy MateAPI)

src/Control/Auth.hs

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

src/Control/Meta.hs

@@ -11,10 +11,8 @@ 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,8 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Control.Settings where
 
-import Control.Monad (void, unless)
-
 import Control.Monad.Reader
 
 import Servant

src/Model/Auth.hs

@@ -4,7 +4,6 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
 module Model.Auth where
 
 import Servant
@@ -18,14 +17,7 @@ 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)
 
@@ -42,6 +34,9 @@ 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
@@ -54,7 +49,7 @@ import Util.Crypto
 initToken :: PGS.Query
 initToken = mconcat
   [ "CREATE TABLE IF NOT EXISTS \"token\" ("
-  , "token_id     SERIAL      PRIMARY KEY,"
+  , "token_string BYTEA       NOT NULL PRIMARY KEY,"
   , "token_user   INTEGER     REFERENCES \"user\"(user_id) NOT NULL,"
   , "token_expiry TIMESTAMPTZ NOT NULL,"
   , "token_method INT         NOT NULL"
@@ -62,19 +57,19 @@ initToken = mconcat
   ]
 
 tokenTable :: Table
-  ( Maybe (Field SqlInt4)
+  ( Field SqlBytea
   , Field SqlInt4
   , Field SqlTimestamptz
   , Field SqlInt4
   )
-  ( Field SqlInt4
+  ( Field SqlBytea
   , Field SqlInt4
   , Field SqlTimestamptz
   , Field SqlInt4
   )
 tokenTable = table "token" (
   p4
-    ( tableField "token_id"
+    ( tableField "token_string"
     , tableField "token_user"
     , tableField "token_expiry"
     , tableField "token_method"
@@ -219,31 +214,22 @@ deleteAuthDataById adid conn = liftIO $ runDelete_ conn $ Delete
 
 validateToken
   :: ByteString
-  -> JWK
   -> PGS.Connection
   -> Handler (Maybe (Int, AuthMethod))
-validateToken authHeader key conn = do
+validateToken header 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@(_, tUser, _, tMethod) <- (selectTable tokenTable) -< ()
+      stuff@(tstr, _, _, _) <- (selectTable tokenTable) -< ()
-      restrict -<
+      restrict -< toFields header .== tstr
-        toFields (authUser token) .== tUser .&&
-        toFields (fromEnum $ authMethod token) .== tMethod
       returnA -< stuff
     )
   case tokens of
-    [Token tid uid stamp method] -> do
+    [Token _ uid stamp method] -> do
       now_ <- liftIO getCurrentTime
       if diffUTCTime stamp now_ > 0
       then return $ Just (uid, method)
       else do
-        void $ deleteToken tid conn
+        void $ deleteToken header conn
         liftIO $ threadDelay delayTime
         throwError $ err401
           { errBody = "Your token expired!"
@@ -256,12 +242,11 @@ validateToken authHeader key conn = do
 
 
 generateToken
-  :: Int
+  :: Ticket
-  -> AuthMethod
   -> AuthResponse
   -> PGS.Connection
-  -> MateHandler SignedJWT
+  -> MateHandler AuthResult
-generateToken tuid method (AuthResponse response) conn = do
+generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do
   authData <- liftIO $ map fromDatabase <$> runSelect conn (
     proc () -> do
       stuff@(_, auid, amethod, _, _, _) <- selectTable authDataTable -< ()
@@ -278,22 +263,15 @@ generateToken tuid method (AuthResponse response) conn = do
   -- liftIO $ print (response : userPayloads)
   if authResult
   then do
-    key <- asks rsJWTSecret
+    token <- liftIO $ Token
-    issuedAt <- liftIO getCurrentTime
+      <$> (decodeUtf8 <$> randomString)
-    let preToken =
+      <*> pure tuid
-          ( tuid
+      <*> (addUTCTime (23*60) <$> getCurrentTime)
-          , (addUTCTime (23*60) issuedAt)
+      <*> pure method
-          , method
+    void $ insertToken token conn
-          )
+    return $ Granted (AuthToken $ tokenString token)
-    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
-    throwError err401
+    return Denied
   where
     validatePass resp =
       foldM
@@ -309,39 +287,37 @@ generateToken tuid method (AuthResponse response) conn = do
           )
         False
     validateChallengeResponse _ _ =
-      throwError err501
+      error "Validation of challenge response authentication not yet implemented"
-        { errBody = "Validation of challenge response authentication not yet implemented"
-        }
 
 
 insertToken
-  :: (Int, UTCTime, AuthMethod)
+  :: Token
   -> PGS.Connection
-  -> MateHandler Int
+  -> MateHandler ByteString
-insertToken (tUser, tExpiry, tMethod) conn =
+insertToken (Token tString tUser tExpiry tMethod) conn =
   fmap head $ liftIO $ runInsert_ conn $ Insert
     { iTable = tokenTable
     , iRows =
       [
-      ( toFields (Nothing :: Maybe Int)
+      ( toFields (encodeUtf8 tString)
       , toFields tUser
       , toFields tExpiry
       , toFields (fromEnum tMethod)
       )
       ]
-    , iReturning = rReturning (\(tid, _, _, _) -> tid)
+    , iReturning = rReturning (\(ident, _, _, _) -> ident)
     , iOnConflict = Nothing
     }
 
 
 deleteToken
-  :: Int
+  :: ByteString
   -> PGS.Connection
   -> Handler Int64
-deleteToken dtid conn =
+deleteToken tstr conn =
   liftIO $ runDelete_ conn $ Delete
     { dTable     = tokenTable
-    , dWhere     = \(tid, _,  _, _) -> tid .== toFields dtid
+    , dWhere     = \(rtstr, _, _, _) -> rtstr .== toFields tstr
     , dReturning = rCount
     }
 
@@ -388,14 +364,25 @@ newTicket ident method = do
 
 processAuthRequest
   :: AuthRequest
+  -> S.Set Ticket
   -> PGS.Connection
-  -> MateHandler SignedJWT
+  -> MateHandler AuthResult
-processAuthRequest (AuthRequest user method pass) conn = do
+processAuthRequest (AuthRequest aticket pass) store conn = do
-  -- liftIO $ putStrLn "there is a ticket..."
+  let mticket = S.filter (\st -> ticketId st == aticket) store
-  now_ <- liftIO getCurrentTime
+  case S.toList mticket of
-  liftIO $ threadDelay delayTime
+    [ticket] -> do
-  -- liftIO $ putStrLn "...and it is valid"
+      -- liftIO $ putStrLn "there is a ticket..."
-  generateToken user method pass conn
+      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
 
 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,14 +1,10 @@
 {-# 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
@@ -113,8 +109,7 @@ instance FromJSON AuthResponse
 instance ToSchema AuthResponse
 
 data AuthRequest = AuthRequest
-  { authRequestUser     :: Int
+  { authRequestTicket   :: AuthTicket
-  , authRequestMethod   :: AuthMethod
   , authRequestPassword :: AuthResponse
   }
   deriving (Show, Generic)
@@ -125,24 +120,18 @@ instance ToJSON AuthRequest where
 instance FromJSON AuthRequest
 instance ToSchema AuthRequest
 
-data AuthResult = AuthResult
+data AuthResult
-  { authTime   :: UTCTime
+  = Granted
-  , authUser   :: Int
+    { authToken :: AuthToken
-  , authMethod :: AuthMethod
+    }
-  -- , authToken  :: AuthToken
+  | Denied
-  }
+    deriving (Show, Generic)
-  deriving (Show, Generic)
 
 instance ToJSON AuthResult where
   toEncoding = genericToEncoding defaultOptions
 
 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)
 
@@ -153,7 +142,7 @@ instance FromJSON AuthToken
 instance ToSchema AuthToken
 
 data Token = Token
-  { tokenId     :: Int
+  { tokenString :: T.Text
   , tokenUser   :: Int
   , tokenExpiry :: UTCTime
   , tokenMethod :: AuthMethod
@@ -169,12 +158,12 @@ data Token = Token
 
 instance DatabaseRepresentation Token where
 
-  type Representation Token = (Int, Int, UTCTime, Int)
+  type Representation Token = (ByteString, Int, UTCTime, Int)
 
 instance FromDatabase Token where
 
-  fromDatabase (tId, usr, expiry, method) =
+  fromDatabase (string, usr, expiry, method) =
-    Token tId usr expiry (toEnum method)
+    Token (decodeUtf8 string) usr expiry (toEnum method)
 
 
 type TicketStore = TVar (S.Set Ticket)

src/Types/Reader.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleInstances #-}
 module Types.Reader where
 
 import qualified Data.Text as T
@@ -7,11 +5,7 @@ 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)
 
@@ -29,10 +23,6 @@ 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,7 +72,6 @@ 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,5 +1,4 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PackageImports #-}
 module AppMainSpec where
 
 import Database.PostgreSQL.Transact
@@ -10,11 +9,11 @@ import Control.Monad.IO.Class (liftIO)
 
 -- internal imports
 
-import qualified "mateamt" Util as LibUtil
+import Util
 import TestUtil
 
 spec :: Spec
 spec = describeDB (const $ return ()) "Initialize DB" $
-  itDB "call initialization script" $ do
+  itDB "calls initialization script" $ do
     conn <- getConnection
-    liftIO $ shouldReturn (LibUtil.initDB conn) ()
+    liftIO $ shouldReturn (initDB conn) ()

test/TestMain.hs

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