wai_auth.hs

getSessionFromDb :: SQLite.Connection -> ByteString -> IO (Maybe Session)
getSessionFromDb conn id =
  SQLite.query conn "SELECT expires,userid FROM sessions WHERE id = ?" [id]
    >>= \dbResult -> case dbResult of
      [s :: Session] -> return $ Just s
      [] -> return Nothing
      other -> throwString $ "unexpected DB result: " <> show other

getRolesFromDb :: SQLite.Connection -> Int -> IO (Maybe [Role])
getRolesFromDb conn userId =
  let q =
        [sql|
           WITH roles_for_id AS (SELECT role FROM user_roles WHERE id = ?)
           SELECT label FROM roles_for_id JOIN roles ON id = role
        |]
   in do
        r <- SQLite.query conn q [userId]
        case r of
          [roles :: [Role]] -> return $ Just roles
          [] -> return Nothing
          other -> throwString $ "unexpected result from DB for session" <> show other

checkSession :: Session -> IO (Either Text ValidSession)
checkSession s@(Session expires _) = do
  now <- Time.getCurrentTime
  return $
    if now >= expires
      then Left $ "session expired at: " <> Text.pack (show expires)
      else Right $ ValidSession s

-- Consider renewing session ID everytime
sessionMiddleware ::
  SQLite.Connection ->
  ClientSession.Key ->
  Vault.Key [Role] ->
  Log.FastLogger ->
  Wai.Middleware
sessionMiddleware conn sessionKey vaultKey logger nextApp req send = do
  unexpectedExceptions <-
    tryAny . TME.runExceptT $
      ( TME.ExceptT . return . note "no cookie header" . lookup "cookie" . Wai.requestHeaders
          >=> TME.ExceptT . return . note "no session cookie" . lookup "lions_session" . Cookie.parseCookies
          >=> TME.ExceptT . return . note "empty session cookie" . ClientSession.decrypt sessionKey
          >=> (\sessionId -> TME.ExceptT . fmap (note ("no session for id: " <> showt sessionId)) $ getSessionFromDb conn sessionId)
          >=> TME.ExceptT . checkSession
          >=> (\(ValidSession (Session _ userId)) -> TME.ExceptT . fmap (note ("no roles for userid: " <> showt userId)) $ getRolesFromDb conn userId)
      )
        req
  case unexpectedExceptions of
    Left e -> do
      send $ Wai.responseBuilder status500 [] "Interner Fehler"
    Right expectedErrors ->
      case expectedErrors of
        Left e -> do
          case Wai.pathInfo req of
            ["login"] -> nextApp req send
            _ -> do
              send $ Wai.responseBuilder status302 [("Location", (encodeUtf8 $ snd3 loginL))] ""
        Right roles -> do
          let vault' = Vault.insert vaultKey roles (Wai.vault req)
              req' = req {Wai.vault = vault'}
          logger "successful session authentication in middleware\n"
          nextApp req' send

getSessionFromDb :: SQLite.Connection -> ByteString -> IO (Maybe Session)
getSessionFromDb conn id =
  SQLite.query conn "SELECT expires,userid FROM sessions WHERE id = ?" [id]
    >>= \dbResult -> case dbResult of
      [s :: Session] -> return $ Just s
      [] -> return Nothing
      other -> throwString $ "unexpected DB result: " <> show other

getRolesFromDb :: SQLite.Connection -> Int -> IO (Maybe [Role])
getRolesFromDb conn userId =
  let q =
        [sql|
           WITH roles_for_id AS (SELECT role FROM user_roles WHERE id = ?)
           SELECT label FROM roles_for_id JOIN roles ON id = role
        |]
   in do
        r <- SQLite.query conn q [userId]
        case r of
          [roles :: [Role]] -> return $ Just roles
          [] -> return Nothing
          other -> throwString $ "unexpected result from DB for session" <> show other

checkSession :: Session -> IO (Either Text ValidSession)
checkSession s@(Session expires _) = do
  now <- Time.getCurrentTime
  return $
    if now >= expires
      then Left $ "session expired at: " <> Text.pack (show expires)
      else Right $ ValidSession s

-- Consider renewing session ID everytime
sessionMiddleware ::
  SQLite.Connection ->
  ClientSession.Key ->
  Vault.Key [Role] ->
  Log.FastLogger ->
  Wai.Middleware
sessionMiddleware conn sessionKey vaultKey logger nextApp req send = do
  unexpectedExceptions <-
    tryAny . TME.runExceptT $
      ( TME.ExceptT . return . note "no cookie header" . lookup "cookie" . Wai.requestHeaders
          >=> TME.ExceptT . return . note "no session cookie" . lookup "lions_session" . Cookie.parseCookies
          >=> TME.ExceptT . return . note "empty session cookie" . ClientSession.decrypt sessionKey
          >=> (\sessionId -> TME.ExceptT . fmap (note ("no session for id: " <> showt sessionId)) $ getSessionFromDb conn sessionId)
          >=> TME.ExceptT . checkSession
          >=> (\(ValidSession (Session _ userId)) -> TME.ExceptT . fmap (note ("no roles for userid: " <> showt userId)) $ getRolesFromDb conn userId)
      )
        req
  case unexpectedExceptions of
    Left e -> do
      logger . Log.toLogStr $ show e <> "\n"
      send $ Wai.responseBuilder status500 [] "Interner Fehler"
    Right expectedErrors ->
      case expectedErrors of
        Left e -> do
          logger . Log.toLogStr $ e <> "\n"
          case Wai.pathInfo req of
            ["login"] -> nextApp req send
            _ -> do
              send $ Wai.responseBuilder status302 [("Location", (encodeUtf8 $ snd3 loginL))] ""
        Right roles -> do
          let vault' = Vault.insert vaultKey roles (Wai.vault req)
              req' = req {Wai.vault = vault'}
          logger "successful session authentication in middleware\n"
          nextApp req' send
          
app ::
  SQLite.Connection ->
  Log.FastLogger ->
  ClientSession.Key ->
  Vault.Key [Role] ->
  Wai.Application
app conn logger sessionKey vaultKey req send =
  case Wai.pathInfo req of
    [] ->
      send
        . Wai.responseLBS status200 [("Content-Type", "text/html; charset=UTF-8")]
        . renderBS
        . layout welcomeL
        $ div_ "hello!"
    ["login"] ->
      let isLoggedIn = isJust . Vault.lookup vaultKey $ Wai.vault req
       in case Wai.requestMethod req of
            "POST" -> do
              (params, _) <- parseRequestBodyEx defaultParseRequestBodyOptions lbsBackEnd req
              let p = paramsMap params
                  email = Map.findWithDefault "" "email" p
                  formPw = Map.findWithDefault "" "password" p
              -- TODO: handle exceptions
              r <- SQLite.query conn "SELECT id, password_digest FROM users WHERE email = ?" [email]
              case r of
                [(userId :: Int, dbPw :: Text)] -> do
                  if BCrypt.validatePassword (encodeUtf8 dbPw) (encodeUtf8 formPw)
                    then do
                      cookieHeader <- authenticateUserId logger conn sessionKey userId
                      send
                        . Wai.responseLBS
                          status200
                          [ ("Content-Type", "text/html; charset=UTF-8"),
                            ("Set-Cookie", cookieHeader),
                            ("Location", "/")
                          ]
                        . renderBS
                        $ loginForm "" "" False
                    else do
                      logger "unsuccessful login\n"
                      send
                        -- TODO: 401?
                        . Wai.responseLBS status403 [("Content-Type", "text/html; charset=UTF-8")]
                        . renderBS
                        $ loginForm email formPw False
                [] -> do
                  send
                    -- TODO: 401?
                    . Wai.responseLBS status403 [("Content-Type", "text/html; charset=UTF-8")]
                    . renderBS
                    -- TODO: Send errors to client
                    $ loginForm "" "" False
            _ ->
              send
                . Wai.responseLBS status200 [("Content-Type", "text/html; charset=UTF-8")]
                . renderBS
                $ loginForm "" "" isLoggedIn
    _ -> send $ Wai.responseLBS status404 [("Content-Type", "text/plain; charset=UTF-8")] "Nicht gefunden"