Authentication works for now

This commit is contained in:
nek0 2019-10-04 09:04:23 +02:00
parent 63335d41ae
commit df11ebcc0a
11 changed files with 280 additions and 115 deletions

View file

@ -23,8 +23,8 @@ executable matebeamter
, ClientAuth , ClientAuth
, Util , Util
, Hash , Hash
, Session
, Types , Types
, Types.Auth
, Types.Page , Types.Page
, Types.Reader , Types.Reader
, Types.Views , Types.Views

View file

@ -18,6 +18,8 @@ import Servant.HTML.Blaze
import Data.Proxy import Data.Proxy
import qualified Data.Text as T
-- imports from "mateamt" -- imports from "mateamt"
import qualified "mateamt" Types as MT import qualified "mateamt" Types as MT
@ -27,16 +29,28 @@ import qualified "mateamt" Types as MT
import Types import Types
type UserAPI = type UserAPI =
Get '[HTML] UserSelectPage Header "Cookie" T.Text :> (Get '[HTML] UserSelectPage
:<|> "user" :> Capture "id" Int :> Get '[HTML] UserOverviewPage :<|> "user" :> Capture "id" Int
:> Get '[HTML] UserOverviewPage
:<|> "user" :> "create" :> Get '[HTML] UserNewPage :<|> "user" :> "create" :> Get '[HTML] UserNewPage
:<|> "user" :> "create" :> ReqBody '[FormUrlEncoded] MT.UserSubmit :> Post '[HTML] UserSelectPage :<|> "user" :> "create" :> ReqBody '[FormUrlEncoded] MT.UserSubmit
:<|> "auth" :> Get '[HTML] AuthPage :> Post '[HTML] UserSelectPage
:<|> "auth"
:> Get '[HTML]
(Headers
'[ Header "Set-Cookie" T.Text
, Header "Set-Cookie" T.Text
, Header "Set-Cookie" T.Text
]
AuthPage)
:<|> "auth" :> ReqBody '[FormUrlEncoded] AuthReturn
:> Post '[HTML] UserSelectPage
)
( userSelectLink :<|> ( userSelectLink :<|>
userOverviewLink :<|> userOverviewLink :<|>
userNewLink :<|> userNewLink :<|>
userNewPostLink :<|> userNewPostLink :<|>
authLink authLink :<|>
authPostLink
) = allLinks (Proxy :: Proxy UserAPI) ) = allLinks (Proxy :: Proxy UserAPI)

View file

@ -1,12 +1,147 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Control.Auth where module Control.Auth where
import Servant.Server (Server) import Servant
import Servant.Client
import qualified Data.Text as T
import Data.Text.I18n
import Data.String (fromString)
import Data.Maybe (fromMaybe)
import Data.Either (isRight, rights, lefts)
import Control.Monad (foldM)
import Control.Monad.Reader (ask)
import Control.Monad.IO.Class (liftIO)
-- imports from "mateamt"
import qualified "mateamt" Types as MT
-- internal imports -- internal imports
import Types import Types
import View import View
import Util
import Client
import API
import Hash
authControl :: UserHandler AuthPage authControl
authControl = do :: Maybe T.Text
error "Not yet implemented properly" -> UserHandler
(Headers
'[ Header "Set-Cookie" T.Text
, Header "Set-Cookie" T.Text
, Header "Set-Cookie" T.Text
]
AuthPage)
authControl mcookie@(Just cookie) = do
let mauthUser = lookup "x-auth-user" (parseCookieText cookie)
case mauthUser of
Just authUser -> do
(ReadState _ backend _) <- ask
let trs = map
(MT.TicketRequest
(read (T.unpack authUser) :: Int))
passes
passes =
[ MT.PrimaryPass
, MT.SecondaryPass
]
eAuthInfos <- zip passes <$>
(liftIO $ mapM
(\req -> runClientM
(authGet req)
backend
)
trs
)
if any (isRight . snd) eAuthInfos
then digestAuthInfo (uncurry zip $ (\(as, bs) -> (as, rights bs)) $
unzip eAuthInfos)
else throwError $ err400
{ errBody = fromString $ show $ lefts $ snd $ unzip eAuthInfos
}
Nothing ->
error $ "Error handling not yet implemented properly, but here's your user: "
<> (fromString $ T.unpack $ fromMaybe "" $
lookup "x-auth-user" (parseCookieText cookie)
)
where
digestAuthInfo
:: [(MT.AuthMethod, MT.AuthInfo)]
-> UserHandler
(Headers
'[ Header "Set-Cookie" T.Text
, Header "Set-Cookie" T.Text
, Header "Set-Cookie" T.Text
]
AuthPage)
digestAuthInfo tupAuthInfos = do
(ReadState l10n _ _) <- ask
let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
ticketHeaders = map
(\(method, MT.AuthInfo _ (MT.AuthTicket ticket)) ->
"x-ticket-"<> fromString (show $ fromEnum method) <>"=" <>
(fromString $ T.unpack ticket) <> ";Path=/")
tupAuthInfos
return $ addHeader
"x-auth-user=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT" $
addHeader (ticketHeaders !! 0) $
addHeader (ticketHeaders !! 1) $
authPage l10n loc
authControl Nothing =
throwError $ err400
{ errBody = "No cookie present."
}
authPostControl
:: Maybe T.Text
-> AuthReturn
-> UserHandler UserSelectPage
authPostControl (Just cookies) (AuthReturn pass method) = do
let mticket = lookup ("x-ticket-" <> fromString (show method)) $
parseCookieText cookies
case mticket of
Just ticket -> do
(ReadState _ backend _) <- ask
hashedPass <- hashPassword pass
etoken <- liftIO $ runClientM
(authSend
(MT.AuthRequest
(MT.AuthTicket ticket)
(MT.AuthResponse hashedPass)
)
)
backend
case etoken of
Right (MT.Granted (MT.AuthToken token)) -> do
let headers = errHeaders $ redirect303 userSelectLink -- FIXME: redirect to product select
throwError $ err303
{ errHeaders = headers ++
[ ("Set-Cookie", "x-ticket-0=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT")
, ("Set-Cookie", "x-ticket-1=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT")
, ("Set-Cookie", "x-token=" <> fromString (T.unpack token) <>";Path=/")
]
}
Right MT.Denied -> throwError $ err401
{ errBody = "Authentication failed! " <> fromString (T.unpack hashedPass)
}
Left err -> throwError $ err500
{ errBody = fromString $ show err
}
Nothing -> throwError $ err400
{ errBody = "No ticket cookie present."
}
authPostControl Nothing _ = throwError $ err400
{ errBody = "No ticket cookie present."
}

View file

@ -1,5 +1,6 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
{-# LANGUAGE DataKinds #-}
module Control.User where module Control.User where
import Servant import Servant
@ -9,8 +10,11 @@ import Servant.Server
import Data.String (fromString) import Data.String (fromString)
import qualified Data.Text as T
import Data.Text.I18n import Data.Text.I18n
import Data.Maybe (fromMaybe)
import Control.Monad (void) import Control.Monad (void)
import Control.Monad.Reader (ask) import Control.Monad.Reader (ask)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
@ -32,10 +36,11 @@ import Hash
import API import API
import Util import Util
userSelectControl :: UserHandler UserSelectPage userSelectControl :: Maybe T.Text -> UserHandler UserSelectPage
userSelectControl = do userSelectControl mcookie = do
(ReadState l10n backend _) <- ask (ReadState l10n backend _) <- ask
let loc = Locale "en" let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
euser <- liftIO $ runClientM euser <- liftIO $ runClientM
(userList (Nothing)) (userList (Nothing))
backend backend
@ -45,16 +50,18 @@ userSelectControl = do
Left err -> Left err ->
error $ show err error $ show err
userNewControl :: UserHandler UserNewPage userNewControl :: Maybe T.Text -> UserHandler UserNewPage
userNewControl = do userNewControl mcookie = do
(ReadState l10n backend _) <- ask (ReadState l10n backend _) <- ask
let loc = Locale "en" let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
return $ userNewPage l10n loc return $ userNewPage l10n loc
userNewPostControl userNewPostControl
:: MT.UserSubmit :: Maybe T.Text
-> MT.UserSubmit
-> UserHandler UserSelectPage -> UserHandler UserSelectPage
userNewPostControl us@(MT.UserSubmit ident email pass) = do userNewPostControl _ us@(MT.UserSubmit ident email pass) = do
backend <- rsBackend <$> ask backend <- rsBackend <$> ask
hashedPass <- hashPassword pass hashedPass <- hashPassword pass
void $ liftIO $ runClientM void $ liftIO $ runClientM
@ -62,12 +69,16 @@ userNewPostControl us@(MT.UserSubmit ident email pass) = do
{ MT.userSubmitPassHash = hashedPass { MT.userSubmitPassHash = hashedPass
}) })
backend backend
redirect303 userSelectLink throwError $ redirect303 userSelectLink
userOverviewControl :: Int -> UserHandler UserOverviewPage userOverviewControl
userOverviewControl uid = do :: Maybe T.Text
-> Int
-> UserHandler UserOverviewPage
userOverviewControl mcookie uid = do
(ReadState l10n backend _) <- ask (ReadState l10n backend _) <- ask
let loc = Locale "en" let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
euser <- liftIO $ runClientM euser <- liftIO $ runClientM
(userGet (mkAuthenticatedRequest "secret" authenticateReq) uid) (userGet (mkAuthenticatedRequest "secret" authenticateReq) uid)
backend backend
@ -80,8 +91,17 @@ userOverviewControl uid = do
(Left uerr, Right _) -> case uerr of (Left uerr, Right _) -> case uerr of
FailureResponse _ resp -> FailureResponse _ resp ->
if statusCode (responseStatusCode resp) == 401 if statusCode (responseStatusCode resp) == 401
then then do
redirect303 authLink let redirectHeaders = errHeaders $ redirect303 authLink
throwError
(err303
{ errHeaders = redirectHeaders ++
[ ("Set-Cookie", "x-auth-user=" <> (fromString $ show uid)
<> "; Path=/"
)
]
}
)
else else
throwError $ err500 throwError $ err500
{ errBody = fromString (show uerr) { errBody = fromString (show uerr)

View file

@ -21,7 +21,8 @@ hashPassword
:: T.Text :: T.Text
-> UserHandler T.Text -> UserHandler T.Text
hashPassword passwd = do hashPassword passwd = do
(HashParams iter saltl outputl) <- rsHashParams <$> ask (HashParams iter _ outputl) <- rsHashParams <$> ask
let saltl = 0
salt <- liftIO $ random (fromIntegral saltl) salt <- liftIO $ random (fromIntegral saltl)
let hash = generate (prfHMAC SHA3_512) (Parameters iter outputl) (encodeUtf8 passwd) salt :: ByteString let hash = generate (prfHMAC SHA3_512) (Parameters iter outputl) (encodeUtf8 passwd) salt :: ByteString
return $ decodeUtf8 $ B64.encode hash return $ decodeUtf8 $ B64.encode hash

View file

@ -8,48 +8,33 @@ import Servant.Client
import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp
import Network.Wai.Logger import Network.Wai.Logger
import Network.Wai.Session
import Network.HTTP.Client hiding (Proxy) import Network.HTTP.Client hiding (Proxy)
import Web.Cookie (defaultSetCookie)
import Control.Monad.Reader import Control.Monad.Reader
import Data.Text.I18n import Data.Text.I18n
import Data.Text.I18n.Po import Data.Text.I18n.Po
import Data.ByteString (ByteString)
import qualified Data.Vault.Lazy as V
-- internal imports -- internal imports
import API import API
import Types import Types
import View import View
import Control import Control
import Session
main :: IO () main :: IO ()
main = do main = do
manager <- newManager defaultManagerSettings manager <- newManager defaultManagerSettings
(l10n, _) <- getL10n "./locales" (l10n, _) <- getL10n "./locales"
withStdoutLogger $ \ilog -> do withStdoutLogger $ \ilog -> do
sessKey <- V.newKey :: IO (V.Key (Session IO ByteString ByteString))
let settings = setPort 3000 $ setLogger ilog defaultSettings let settings = setPort 3000 $ setLogger ilog defaultSettings
sessMap = sessionMap
initState = ReadState initState = ReadState
-- { rsManager = manager -- { rsManager = manager
{ rsL10n = l10n { rsL10n = l10n
, rsBackend = mkClientEnv manager (BaseUrl Http "localhost" 8000 "") , rsBackend = mkClientEnv manager (BaseUrl Http "localhost" 8000 "")
, rsHashParams = recommendedHashParams , rsHashParams = recommendedHashParams
} }
cookieMiddleware = withSession
(sessionStore genSessionId sessMap)
"mateamt-cookies"
defaultSetCookie
sessKey
runSettings settings (userApp initState) runSettings settings (userApp initState)
@ -58,11 +43,12 @@ userApp initState = serveWithContext userApi (EmptyContext) $
userApi userApi
Proxy Proxy
(`runReaderT` initState) (`runReaderT` initState)
( userSelectControl (\mcookie -> userSelectControl mcookie
:<|> userOverviewControl :<|> userOverviewControl mcookie
:<|> userNewControl :<|> userNewControl mcookie
:<|> userNewPostControl :<|> userNewPostControl mcookie
:<|> authControl :<|> authControl mcookie
:<|> authPostControl mcookie
) )
userApi :: Proxy UserAPI userApi :: Proxy UserAPI

View file

@ -1,60 +0,0 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Session where
import Network.Wai.Session
import Control.Monad (liftM)
import Control.Concurrent.STM
import Control.Concurrent.STM.TVar
import qualified StmContainers.Map as SMap
import System.IO.Unsafe (unsafePerformIO)
import Data.Maybe (fromJust)
import Data.ByteString (ByteString)
import Data.Hashable
sessionMap = unsafePerformIO SMap.newIO
sessionStore
:: IO ByteString
-> SMap.Map ByteString (SMap.Map ByteString ByteString)
-> SessionStore IO ByteString ByteString
-- -> IO ((key2 -> IO (Maybe value)), (key2 -> value -> IO ()))
sessionStore genKey inmap =
mapStore genKey inmap
where
mapStore
:: IO ByteString
-> SMap.Map ByteString (SMap.Map ByteString ByteString)
-> SessionStore IO ByteString ByteString
-- -> IO ((key2 -> IO (Maybe value1)), (key2 -> value1 -> IO ()))
mapStore gen map = (\inkey ->
case inkey of
Just k -> do
mcmap <- atomically $ SMap.lookup k map
case mcmap of
Just cmap ->
return $ (sessionMapFromSTMMap cmap, genKey)
Nothing -> (mapStore genKey map) Nothing
Nothing -> do
nkey <- gen
nmap <- atomically $ SMap.new
atomically $ SMap.insert nmap nkey map
cmap <- fromJust <$> (atomically $ SMap.lookup nkey map)
return $ (sessionMapFromSTMMap cmap, gen)
)
sessionMapFromSTMMap
:: SMap.Map ByteString ByteString
-> Session IO ByteString ByteString
sessionMapFromSTMMap inmap =
( \k -> atomically $ SMap.lookup k inmap
, \k v -> atomically $ SMap.insert v k inmap
)

View file

@ -2,6 +2,7 @@ module Types
( module T ( module T
) where ) where
import Types.Auth as T
import Types.Page as T import Types.Page as T
import Types.Reader as T import Types.Reader as T
import Types.Views as T import Types.Views as T

22
src/Types/Auth.hs Normal file
View file

@ -0,0 +1,22 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Types.Auth where
import qualified Data.Text as T
import Servant.API
import Web.Internal.FormUrlEncoded
import Servant.HTML.Blaze
import GHC.Generics
data AuthReturn = AuthReturn
{ authReturnPass :: T.Text
, authReturnMethod :: Int
}
deriving (Show, Generic)
instance MimeRender HTML AuthReturn
instance FromForm AuthReturn

View file

@ -6,7 +6,6 @@ module Util where
import Servant hiding (addHeader) import Servant hiding (addHeader)
import Servant.Client.Core.Request import Servant.Client.Core.Request
import Servant.Client.Core.Auth
import Servant.Client.Core.Request (addHeader) import Servant.Client.Core.Request (addHeader)
import qualified Data.Text as T import qualified Data.Text as T
@ -19,8 +18,6 @@ import Data.List.Split (chunksOf)
import Data.String (fromString) import Data.String (fromString)
import Control.Monad.Error
import Web.Cookie import Web.Cookie
import Text.Printf (printf) import Text.Printf (printf)
@ -43,12 +40,18 @@ formatMoney amount = pre <> t <> "," <> c
break (== '.') (printf "%.2f" (abs amount)) break (== '.') (printf "%.2f" (abs amount))
redirect303 redirect303
:: MonadError ServerError m :: Link
=> Link -> ServerError
-> m a
redirect303 link = redirect303 link =
throwError $ err303 err303
{ errHeaders = { errHeaders =
[ ("Location", "/" <> (fromString $ show $ linkURI $ link)) [ ("Location", "/" <> (fromString $ show $ linkURI $ link))
] ]
} }
parseCookieText
:: T.Text
-> [(T.Text, T.Text)]
parseCookieText = map
(\x -> let (one, two) = T.breakOn "=" x in (one, T.tail two))
. T.splitOn "; "

View file

@ -1,14 +1,24 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
module View.Auth where module View.Auth where
import Servant.Links (linkURI)
import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA
import Data.Text.I18n import Data.Text.I18n
import Data.String
-- imports from mateamt
import qualified "mateamt" Types.Auth as MT
-- internal imports -- internal imports
import Types import Types
import API
import View.Scaffold import View.Scaffold
authPage authPage
@ -24,6 +34,39 @@ authPage l10n locale = scaffold
translate "Authentication" translate "Authentication"
) )
$ do $ do
H.p $ "Test" H.p $ H.form
H.! HA.method "post"
H.! HA.action ("/" <> (fromString $ show $ linkURI $ authPostLink))
H.! HA.enctype "application/x-www-form-urlencoded" $ do
H.div H.! HA.class_ "form-group required" $ do
H.label H.! HA.for "method" $ H.toHtml $
translate "Authentication Method"
H.select
H.! HA.id "method"
H.! HA.class_ "form-control"
H.! HA.name "authReturnMethod"
H.! HA.required ""
H.! HA.value (fromString $ show $ fromEnum MT.SecondaryPass) $ do
H.option H.!
HA.value (fromString $ show $ fromEnum MT.SecondaryPass) $
H.toHtml $ translate "Secondary Password"
H.option H.!
HA.value (fromString $ show $ fromEnum MT.PrimaryPass) $
H.toHtml $ translate "Primary Password"
H.div H.! HA.class_ "form-group required" $ do
H.label H.! HA.for "password" $ H.toHtml $
translate "Password"
H.input
H.! HA.id "password"
H.! HA.class_ "form_control"
H.! HA.name "authReturnPass"
H.! HA.type_ "password"
H.! HA.required ""
H.! HA.value ""
H.div H.! HA.class_ "form-group optional" $ do
H.button
H.! HA.class_ "btn btn-default"
H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit"
where where
translate = localize l10n locale . gettext translate = localize l10n locale . gettext