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
, Util
, Hash
, Session
, Types
, Types.Auth
, Types.Page
, Types.Reader
, Types.Views

View File

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

View File

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

View File

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

View File

@ -8,48 +8,33 @@ import Servant.Client
import Network.Wai.Handler.Warp
import Network.Wai.Logger
import Network.Wai.Session
import Network.HTTP.Client hiding (Proxy)
import Web.Cookie (defaultSetCookie)
import Control.Monad.Reader
import Data.Text.I18n
import Data.Text.I18n.Po
import Data.ByteString (ByteString)
import qualified Data.Vault.Lazy as V
-- internal imports
import API
import Types
import View
import Control
import Session
main :: IO ()
main = do
manager <- newManager defaultManagerSettings
(l10n, _) <- getL10n "./locales"
withStdoutLogger $ \ilog -> do
sessKey <- V.newKey :: IO (V.Key (Session IO ByteString ByteString))
let settings = setPort 3000 $ setLogger ilog defaultSettings
sessMap = sessionMap
initState = ReadState
-- { rsManager = manager
{ rsL10n = l10n
, rsBackend = mkClientEnv manager (BaseUrl Http "localhost" 8000 "")
, rsHashParams = recommendedHashParams
}
cookieMiddleware = withSession
(sessionStore genSessionId sessMap)
"mateamt-cookies"
defaultSetCookie
sessKey
runSettings settings (userApp initState)
@ -58,11 +43,12 @@ userApp initState = serveWithContext userApi (EmptyContext) $
userApi
Proxy
(`runReaderT` initState)
( userSelectControl
:<|> userOverviewControl
:<|> userNewControl
:<|> userNewPostControl
:<|> authControl
(\mcookie -> userSelectControl mcookie
:<|> userOverviewControl mcookie
:<|> userNewControl mcookie
:<|> userNewPostControl mcookie
:<|> authControl mcookie
:<|> authPostControl mcookie
)
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
) where
import Types.Auth as T
import Types.Page as T
import Types.Reader 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.Client.Core.Request
import Servant.Client.Core.Auth
import Servant.Client.Core.Request (addHeader)
import qualified Data.Text as T
@ -19,8 +18,6 @@ import Data.List.Split (chunksOf)
import Data.String (fromString)
import Control.Monad.Error
import Web.Cookie
import Text.Printf (printf)
@ -43,12 +40,18 @@ formatMoney amount = pre <> t <> "," <> c
break (== '.') (printf "%.2f" (abs amount))
redirect303
:: MonadError ServerError m
=> Link
-> m a
:: Link
-> ServerError
redirect303 link =
throwError $ err303
err303
{ errHeaders =
[ ("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 PackageImports #-}
module View.Auth where
import Servant.Links (linkURI)
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA
import Data.Text.I18n
import Data.String
-- imports from mateamt
import qualified "mateamt" Types.Auth as MT
-- internal imports
import Types
import API
import View.Scaffold
authPage
@ -24,6 +34,39 @@ authPage l10n locale = scaffold
translate "Authentication"
)
$ 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
translate = localize l10n locale . gettext