Mostly working correctly now

src/Aggreact.hs

@@ -67,7 +67,7 @@ data Conf =
 
 type API auths =
   Auth auths User :> Authenticated
-  :<|> LoginAPI
+  :<|> LoginAPI auths
 
 type Authenticated =
   HomepageAPI

src/Aggreact/Auth.hs

@@ -36,8 +36,9 @@ import           Protolude
 
 --------------------------------------------------------------------------------
 import           Aggreact.Html
-import           Aggreact.Users      (NewUser (..), User, UserHandler (..),
-                                      checkUserLogin, loginWidget)
+import           Aggreact.Users              (NewUser (..), User,
+                                              UserHandler (..), checkUserLogin,
+                                              loginWidget)
 
 --------------------------------------------------------------------------------
 import           Data.Aeson
@@ -45,9 +46,10 @@ import           Database.Store
 import           Servant
 import           Servant.Auth.Server
 import           Servant.Errors
-import           Servant.HTML.Blaze  (HTML)
-import qualified Text.Blaze.Html5    as H
-import qualified Web.FormUrlEncoded  as Form
+import           Servant.HTML.Blaze          (HTML)
+import qualified Text.Blaze.Html5            as H
+import qualified Text.Blaze.Html5.Attributes as A
+import qualified Web.FormUrlEncoded          as Form
 
 data Login = Login
   { username :: Text
@@ -59,20 +61,47 @@ instance FromJSON Login
 instance Form.FromForm Login where
   fromForm = Form.genericFromForm Form.FormOptions {fieldLabelModifier = identity}
 
-type LoginAPI =
-  "login"
-    :> (ReqBody '[JSON, FormUrlEncoded] Login
-         :> QueryParam "origin" Text
-         :> Post '[JSON, HTML]
-         (Headers '[ Header "Set-Cookie" SetCookie
-                   , Header "Set-Cookie" SetCookie]
-          LoggedIn)
-        :<|> Get '[HTML] LoginPage)
+type LoginAPI auths =
+  ("login" :> (ReqBody '[JSON, FormUrlEncoded] Login
+               :> QueryParam "origin" Text
+               :> Post '[JSON, HTML]
+               (Headers '[ Header "Set-Cookie" SetCookie
+                         , Header "Set-Cookie" SetCookie]
+                LoggedIn)
+               :<|> Get '[HTML] LoginPage))
+  :<|> "pre-logout"
+    :> Auth auths User
+    :> Get '[HTML] PreLogoutPage
+  :<|> "logout"
+    :> Auth auths User
+    :> Get '[HTML] NoContent
 
-serverLoginAPI :: LoginSettings -> Server LoginAPI
+serverLoginAPI :: LoginSettings -> Server (LoginAPI auths)
 serverLoginAPI loginSettings =
-   checkCreds loginSettings
-  :<|> return LoginPage
+  (checkCreds loginSettings
+   :<|> return LoginPage)
+  :<|> preLogout
+  :<|> logout
+
+logout :: (ThrowAll (m a)) => AuthResult t -> m a
+logout (Authenticated _) =
+  throwAll $ err302 { errHeaders = [ ("Location", "/")
+                                   , ("Set-Cookie", "JWT-Cookie=deleted; path=/; expires=Thu, 01 Jan 1970 00:00:00 GMT" ) ] }
+logout _                 = throwAll err401
+
+newtype PreLogoutPage = PreLogoutPage { muser :: Maybe User }
+
+instance H.ToMarkup PreLogoutPage where
+  toMarkup PreLogoutPage{..} =
+    boilerplate (loginWidget muser) $ do
+      H.p "Are you sure you want to logout?"
+      H.a H.! A.href "/logout" $ "Yes"
+      H.text " / "
+      H.a H.! A.href "/" $ "No"
+
+preLogout :: AuthResult User -> Handler PreLogoutPage
+preLogout (Authenticated u) = pure $ PreLogoutPage (Just u)
+preLogout _                 = throwAll err401
 
 data LoginSettings =
   LoginSettings

src/Aggreact/Authorization.hs

@@ -87,42 +87,9 @@ strToScope txt =
       ""       -> Just Write
       _        -> Nothing
 
-unloggedScopes :: AuthorizationStrategy -> Scopes
-unloggedScopes Anybody =
-  [ "comment:read"
-  , "comment:write"
-  , "slug:read"]
-  & traverse strToScope
-  & fmap Set.fromList
-  & fromMaybe Set.empty
-
-unloggedScopes LoggedInOnly =
-  [ "comment:read"
-  , "slug:read"]
-  & traverse strToScope
-  & fmap Set.fromList
-  & fromMaybe Set.empty
-
-scopesFor :: NewUser -> AuthorizationStrategy -> Set Scope
-scopesFor _ Anybody =
-  [ "comment:read"
-  , "comment:write"
-  , "slug:read"]
-  & traverse strToScope
-  & fmap Set.fromList
-  & fromMaybe Set.empty
-
-scopesFor u LoggedInOnly =
-  let scs = case role u of
-        User -> [ "comment:read"
-                , "comment:write"
-                , "slug:read"]
-        Admin -> [ "comment:read"
-                 , "comment:write"
-                 , "slug:read"
-                 , "slug:write"]
-  in
-  scs
+txtLstToScopes :: [Text] -> Scopes
+txtLstToScopes scs =
+    scs
   & traverse strToScope
   & fmap Set.fromList
   & fromMaybe Set.empty
@@ -130,9 +97,27 @@ scopesFor u LoggedInOnly =
 scopeToStr :: Scope -> Text
 scopeToStr (Scope res acc) = res <> case acc of Read -> ":read"; Write -> ":write"
 
+readOnlyScopes :: [Text]
+readOnlyScopes = [ "comment:read", "slug:read" ]
+commentGrantedScopes :: [Text]
+commentGrantedScopes = [ "comment:read", "slug:read" ]
+allScopes :: [Text]
+allScopes = [ "admin", "comment:read", "comment:write", "slug:read", "slug:write" ]
+
 userScopes' :: AuthorizationStrategy -> Maybe User -> Scopes
-userScopes' authStrat Nothing               = unloggedScopes authStrat
-userScopes' authStrat (Just (Entity _ u _)) = scopesFor u authStrat
+userScopes' Anybody Nothing =
+  txtLstToScopes commentGrantedScopes
+userScopes' Anybody (Just (Entity _ NewUser { role = User } _)) =
+  txtLstToScopes commentGrantedScopes
+userScopes' Anybody (Just (Entity _ NewUser { role = Admin } _)) =
+  txtLstToScopes allScopes
+
+userScopes' LoggedInOnly Nothing =
+  txtLstToScopes readOnlyScopes
+userScopes' LoggedInOnly (Just (Entity _ NewUser { role = User } _)) =
+  txtLstToScopes commentGrantedScopes
+userScopes' LoggedInOnly (Just (Entity _ NewUser { role = Admin } _)) =
+  txtLstToScopes allScopes
 
 hasScope' :: AuthorizationStrategy -> Scope -> Maybe User -> Bool
 hasScope' authStrat s u = Set.member s (userScopes' authStrat u)

src/Aggreact/Users/Views.hs

@@ -79,7 +79,7 @@ instance H.ToMarkup UserPage where
 showScopes :: Scopes -> H.Markup
 showScopes scopes = H.div $ do
   H.label "scopes"
-  H.text (displayScopes scopes)
+  H.code (H.text (displayScopes scopes))
 
 showUser :: User -> H.Markup
 showUser user = do
@@ -136,7 +136,11 @@ deleteUserById (Just u) userHandler userId
 
 loginWidget :: Maybe User -> H.Markup
 loginWidget Nothing                = H.a ! A.href "/login" $ H.text "Login"
-loginWidget (Just (Entity _ nu _)) = H.a ! A.href ("/users/" <> cvt (nick nu)) $ H.text (toS (nick nu))
+loginWidget (Just (Entity _ nu _)) = do
+  H.a ! A.href ("/users/" <> cvt (nick nu)) $ H.text (toS (nick nu))
+  H.span ! A.class_ "small" $ do
+    H.text " / "
+    H.a ! A.href "/pre-logout" $ "logout"
 
 -- List Users
 data UsersPage =