diff --git a/matebeamter.cabal b/matebeamter.cabal index f83f422..c142441 100644 --- a/matebeamter.cabal +++ b/matebeamter.cabal @@ -23,8 +23,8 @@ executable matebeamter , ClientAuth , Util , Hash - , Session , Types + , Types.Auth , Types.Page , Types.Reader , Types.Views diff --git a/src/API.hs b/src/API.hs index b64efae..83965fb 100644 --- a/src/API.hs +++ b/src/API.hs @@ -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) diff --git a/src/Control/Auth.hs b/src/Control/Auth.hs index 3971745..70ee276 100644 --- a/src/Control/Auth.hs +++ b/src/Control/Auth.hs @@ -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." + } diff --git a/src/Control/User.hs b/src/Control/User.hs index 83769a0..3ad4269 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -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) diff --git a/src/Hash.hs b/src/Hash.hs index dbf0d25..a79507b 100644 --- a/src/Hash.hs +++ b/src/Hash.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs index b91f528..e9ee339 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/Session.hs b/src/Session.hs deleted file mode 100644 index 76db46d..0000000 --- a/src/Session.hs +++ /dev/null @@ -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 - ) diff --git a/src/Types.hs b/src/Types.hs index 2446163..6d61bd6 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -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 diff --git a/src/Types/Auth.hs b/src/Types/Auth.hs new file mode 100644 index 0000000..65b3668 --- /dev/null +++ b/src/Types/Auth.hs @@ -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 diff --git a/src/Util.hs b/src/Util.hs index b59242e..ad9d937 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -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 "; " diff --git a/src/View/Auth.hs b/src/View/Auth.hs index 75cea1c..6d34445 100644 --- a/src/View/Auth.hs +++ b/src/View/Auth.hs @@ -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