Authentication works for now

matebeamter.cabal

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

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)

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."
+  }

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)

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

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

src/Session.hs

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

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

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

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

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