Compare commits

..

1 commit

Author SHA1 Message Date
nek0 f2d4c88768 disable test suite 2022-09-16 15:55:22 +02:00
16 changed files with 118 additions and 256 deletions

View file

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

View file

@ -10,8 +10,6 @@ module Main where
import Prelude as P
import Crypto.JWT hiding (Context, header)
import Control.Concurrent.STM (newTQueueIO)
import Control.Concurrent (forkIO)
@ -19,25 +17,27 @@ 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
@ -87,7 +87,6 @@ main = do
-- max_conn_per_client
-- block_registration
sendmail_path
jwt_secret
) -> do
conn <- connectPostgreSQL (
"host='" <> fromString (T.unpack db_host) <> "' " <>
@ -143,11 +142,22 @@ 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
runSettings settings (app initState)
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
@ -158,8 +168,7 @@ main = do
app :: ReadState -> Application
-- app conn = serveWithContext userApi genAuthServerContext (users conn)
app initState =
serveWithContext combinedAPI
(genAuthServerContext (rsJWTSecret initState) (rsConnection initState)) server
serveWithContext combinedAPI (genAuthServerContext (rsConnection initState)) server
where
server :: Server CombinedAPI
server = appToServer initState mateAPI thisApi :<|>
@ -173,6 +182,7 @@ appToServer initState myApi =
thisApi :: ServerT MateAPI MateHandler
thisApi =
authGet :<|>
authSend :<|>
authLogout :<|>
@ -236,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 key conn = mkAuthHandler handler
authHandler :: Connection -> AuthHandler Request (Maybe (Int, AuthMethod))
authHandler conn = mkAuthHandler handler
where
handler :: Request -> Handler (Maybe (Int, AuthMethod))
handler req = do
let headers = requestHeaders req
case lookup "Authorization" headers of
Just hh -> do
validateToken (B8.drop 7 hh) key conn
case lookup "Authentication" headers of
Just hh ->
validateToken hh conn
_ ->
return Nothing
@ -260,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))

4
cabal.project Normal file
View file

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

View file

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

View file

@ -1,60 +0,0 @@
{
"nodes": {
"flake-utils": {
"inputs": {
"systems": "systems"
},
"locked": {
"lastModified": 1705309234,
"narHash": "sha256-uNRRNRKmJyCRC/8y1RqBkqWBLM034y4qN7EprSdmgyA=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "1ef2e671c3b0c19053962c07dbda38332dcebf26",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "flake-utils",
"type": "github"
}
},
"nixpkgs": {
"locked": {
"lastModified": 1709116111,
"narHash": "sha256-V7BbC39cGDOzJsCsmg+hCdBu1Tuhqs7kLcPxw86STh4=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "b84d9f029fa675d5ef312f032f322889149daa82",
"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
}

View file

@ -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
];
};
});
}

View file

@ -93,6 +93,7 @@ library
, servant
, servant-server
, servant-openapi3
, servant-rawm >= 0.3.0.0
, servant-rawm-server
, opaleye
, aeson
@ -110,8 +111,6 @@ library
, haskell-gettext
, mime-mail
, directory
, jose >= 0.10
, monad-time
hs-source-dirs: src
default-language: Haskell2010
@ -150,21 +149,20 @@ 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

View file

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

View file

@ -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 Data.Aeson (encode)
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as BL
import Crypto.Error
import Data.String (fromString)
@ -40,8 +32,11 @@ authGet (TicketRequest uid method) =
authSend
:: AuthRequest
-> MateHandler String
authSend req = B8.unpack . BL.toStrict . encodeCompact <$> (processAuthRequest req =<< asks rsConnection)
-> MateHandler AuthResult
authSend req = uncurry (processAuthRequest req) =<< ((,) <$>
(liftIO . readTVarIO =<< asks rsTicketStore) <*>
asks rsConnection
)
authLogout
:: Maybe (Int, AuthMethod)

View file

@ -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
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
)
validateToken header conn = do
tokens <- liftIO $ map fromDatabase <$> runSelect conn (
proc () -> do
stuff@(_, tUser, _, tMethod) <- (selectTable tokenTable) -< ()
restrict -<
toFields (authUser token) .== tUser .&&
toFields (fromEnum $ authMethod token) .== tMethod
stuff@(tstr, _, _, _) <- (selectTable tokenTable) -< ()
restrict -< toFields header .== tstr
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
-> AuthMethod
:: Ticket
-> AuthResponse
-> PGS.Connection
-> MateHandler SignedJWT
generateToken tuid method (AuthResponse response) conn = do
-> MateHandler AuthResult
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
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
token <- liftIO $ Token
<$> (decodeUtf8 <$> randomString)
<*> pure tuid
<*> (addUTCTime (23*60) <$> getCurrentTime)
<*> pure method
void $ insertToken token conn
return $ Granted (AuthToken $ tokenString token)
else
throwError err401
return Denied
where
validatePass resp =
foldM
@ -309,39 +287,37 @@ generateToken tuid method (AuthResponse response) conn = do
)
False
validateChallengeResponse _ _ =
throwError err501
{ errBody = "Validation of challenge response authentication not yet implemented"
}
error "Validation of challenge response authentication not yet implemented"
insertToken
:: (Int, UTCTime, AuthMethod)
:: Token
-> PGS.Connection
-> MateHandler Int
insertToken (tUser, tExpiry, tMethod) conn =
-> MateHandler ByteString
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
processAuthRequest (AuthRequest user method pass) conn = do
-- liftIO $ putStrLn "there is a ticket..."
now_ <- liftIO getCurrentTime
liftIO $ threadDelay delayTime
-- liftIO $ putStrLn "...and it is valid"
generateToken user method pass conn
-> 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
-- 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
processLogout
:: Int

View file

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

View file

@ -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
, authRequestMethod :: AuthMethod
{ authRequestTicket :: AuthTicket
, authRequestPassword :: AuthResponse
}
deriving (Show, Generic)
@ -125,24 +120,18 @@ instance ToJSON AuthRequest where
instance FromJSON AuthRequest
instance ToSchema AuthRequest
data AuthResult = AuthResult
{ authTime :: UTCTime
, authUser :: Int
, authMethod :: AuthMethod
-- , authToken :: AuthToken
}
deriving (Show, Generic)
data AuthResult
= Granted
{ authToken :: AuthToken
}
| Denied
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) =
Token tId usr expiry (toEnum method)
fromDatabase (string, usr, expiry, method) =
Token (decodeUtf8 string) usr expiry (toEnum method)
type TicketStore = TVar (S.Set Ticket)

View file

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

View file

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

View file

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

View file

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