added optional admin credentials

Foundation.hs

@@ -22,6 +22,8 @@ import Text.Jasmine         (minifym)
 import Yesod.Default.Util   (addStaticContentExternal)
 import Yesod.Core.Types     (Logger)
 --snip
+import Yesod.Auth.Hardcoded
+import Yesod.Auth.Message
 import qualified Data.Text as T
 import Network.Wai as Wai
 import Data.List (tail)
@@ -115,6 +117,7 @@ instance Yesod App where
     defaultLayout widget = do
         master <- getYesod
         mmsg <- getMessage
+        musername <- maybeAuthId
 
         -- We break up the default layout into two components:
         -- default-layout is the contents of the body tag, and
@@ -140,9 +143,32 @@ instance Yesod App where
     -- authRoute _ = Just $ AuthR LoginR
 
     -- Routes not requiring authentication.
-    -- isAuthorized (AuthR _) _ = return Authorized
+    isAuthorized (AuthR _) _ = return Authorized
     isAuthorized FaviconR _ = return Authorized
     isAuthorized RobotsR _ = return Authorized
+    -- Routes requiring authentication
+    isAuthorized RestockR _ = isAdmin
+    isAuthorized (UpstockR _) _ = isAdmin
+    isAuthorized NewArticleR _ = isAdmin
+    isAuthorized JournalR _ = isAdmin
+    isAuthorized (JournalPageR _) _ = isAdmin
+    isAuthorized PayoutR _ = isAdmin
+    isAuthorized SummaryR _ = isAdmin
+    isAuthorized SummaryJsonR _ = isAdmin
+    isAuthorized (ModifyR _) _ = isAdmin
+    isAuthorized (DeleteBeverageR _) _ = isAdmin
+    isAuthorized CashCheckR _ = isAdmin
+    isAuthorized UploadInventoryJsonR _ = isAdmin
+    isAuthorized InventoryJsonR _ = isAdmin
+    isAuthorized AvatarR _ = isAdmin
+    isAuthorized (ModifyAvatarR _) _ = isAdmin
+    isAuthorized (AvatarDeleteR _) _ = isAdmin
+    isAuthorized SupplierR _ = isAdmin
+    isAuthorized NewSupplierR _ = isAdmin
+    isAuthorized (SupplierActionsR _) _ = isAdmin
+    isAuthorized (ModifySupplierR _) _ = isAdmin
+    isAuthorized (SupplierDigestR _) _ = isAdmin
+    isAuthorized (DeleteSupplierR _) _ = isAdmin
     -- Default to Authorized for now.
     isAuthorized _ _ = return Authorized
 
@@ -174,6 +200,13 @@ instance Yesod App where
 
     makeLogger = return . appLogger
 
+isAdmin :: YesodAuth master => HandlerT master IO AuthResult
+isAdmin = do
+  mu <- maybeAuthId
+  return $ case mu of
+    Nothing -> AuthenticationRequired
+    Just _  -> Authorized
+
 -- How to run database actions.
 instance YesodPersist App where
     type YesodPersistBackend App = SqlBackend
@@ -183,30 +216,58 @@ instance YesodPersist App where
 instance YesodPersistRunner App where
     getDBRunner = defaultGetDBRunner appConnPool
 
--- instance YesodAuth App where
+instance YesodAuth App where
---     type AuthId App = UserId
+    type AuthId App = Text
 
---     -- Where to send a user after successful login
+    -- Where to send a user after successful login
---     loginDest _ = HomeR
+    loginDest _ = HomeR
---     -- Where to send a user after logout
+    -- Where to send a user after logout
---     logoutDest _ = HomeR
+    logoutDest _ = HomeR
---     -- Override the above two destinations when a Referer: header is present
+    -- Override the above two destinations when a Referer: header is present
---     redirectToReferer _ = True
+    redirectToReferer _ = True
 
---     getAuthId creds = runDB $ do
+    -- getAuthId = return . Just . credsIdent
---         x <- getBy $ UniqueUser $ credsIdent creds
---         case x of
---             Just (Entity uid _) -> return $ Just uid
---             Nothing -> do
---                 fmap Just $ insert User
---                     { userIdent = credsIdent creds
---                     , userPassword = Nothing
---                     }
 
---     -- You can add other plugins like BrowserID, email or OAuth here
+    -- getAuthId creds = runDB $ do
---     authPlugins _ = [authBrowserId def]
+    --     x <- getBy $ UniqueUser $ credsIdent creds
+    --     case x of
+    --         Just (Entity uid _) -> return $ Just uid
+    --         Nothing -> do
+    --             fmap Just $ insert User
+    --                 { userIdent = credsIdent creds
+    --                 , userPassword = Nothing
+    --                 }
 
---     authHttpManager = getHttpManager
+    authenticate Creds{..} = do
+        settings <- getsYesod appSettings
+        maybe (return $ Authenticated "nobody") (\login ->
+            if loginName login == credsIdent
+            then return (Authenticated credsIdent)
+            else return (UserError InvalidLogin)
+            ) (appAdminCreds settings)
+
+    -- You can add other plugins like BrowserID, email or OAuth here
+    authPlugins _ = [authHardcoded]
+
+    authHttpManager = getHttpManager
+
+    maybeAuthId = do
+      settings <- getsYesod appSettings
+      maybe (return $ Just "nobody")
+        (const $ lookupSession credsKey)
+        (appAdminCreds settings)
+
+instance YesodAuthHardcoded App where
+    validatePassword u p = do
+        settings <- getsYesod appSettings
+        maybe (return True) (\login ->
+            return (u == loginName login && p == loginPass login)
+            ) (appAdminCreds settings)
+
+    doesUserNameExist u = do
+        settings <- getsYesod appSettings
+        let name = fromMaybe "nobody" $ loginName <$> appAdminCreds settings
+        return (u == name)
 
 -- instance YesodAuthPersist App
 

Handler/Common.hs

@@ -34,7 +34,9 @@ import Import
 -- runtime dependency, and for efficiency.
 
 getFaviconR :: Handler TypedContent
-getFaviconR = return $ TypedContent "image/x-icon"
+getFaviconR = do
+  cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month
+  return $ TypedContent "image/x-icon"
     $ toContent $(embedFile "config/favicon.ico")
 
 getRobotsR :: Handler TypedContent

Settings.hs

@@ -76,8 +76,20 @@ data AppSettings = AppSettings
     , appCopyright              :: Text
     , appCopyrightLink          :: Text
     -- ^ Text and link to source
+    , appAdminCreds             :: Maybe Login
     }
 
+data Login = Login
+  { loginName :: Text
+  , loginPass :: Text
+  }
+
+instance FromJSON Login where
+  parseJSON = withObject "Login" $ \o -> do
+    loginName <- o .: "login"
+    loginPass <- o .: "password"
+    return Login{..}
+
 instance FromJSON AppSettings where
     parseJSON = withObject "AppSettings" $ \o -> do
         let defaultDev =
@@ -106,6 +118,8 @@ instance FromJSON AppSettings where
         appCopyright              <- o .: "copyright"
         appCopyrightLink          <- o .: "copyright_link"
 
+        appAdminCreds             <- o .:? "credentials"
+
         return AppSettings {..}
 
 -- | Settings for 'widgetFile', such as which template languages to support and

config/routes

@@ -1,3 +1,4 @@
+/auth AuthR Auth getAuth
 /static StaticR Static appStatic
 
 /favicon.ico FaviconR GET

config/settings.yml

@@ -32,3 +32,7 @@ cash_charge: 50
 
 copyright: "Powered by YAMMAT"
 copyright_link: "https://github.com/nek0/yammat"
+
+# credentials:
+#   login: "admin"
+#   password: "password"

messages/cz.msg

@@ -143,3 +143,5 @@ CustomerId: Kód zákazníka
 TotalCrates: Celkový počet přepravek
 Modify: upravit
 UserIdentNotUnique: Uživatelské jméno není jedinečný
+Login: Přihlásit
+Logout: Odhlásit

messages/de.msg

@@ -143,3 +143,5 @@ CustomerId: Kundennummer
 TotalCrates: Gesamtanzahl Kästen
 Modify: bearbeiten
 UserIdentNotUnique: Benutzername ist nicht einzigartig
+Login: Login
+Logout: Logout

messages/en.msg

@@ -143,3 +143,5 @@ CustomerId: Customer id
 TotalCrates: Total crates
 Modify: modify
 UserIdentNotUnique: Username is not unique
+Login: Login
+Logout: Logout

templates/default-layout.hamlet

@@ -26,6 +26,7 @@
   <hr>
 
   <footer>
+    $maybe username <- musername
       <span>
         <a href=@{RestockR}>_{MsgRestock}
       <span>
@@ -36,5 +37,11 @@
         <a href=@{AvatarR}>_{MsgAvatars}
       <span>
         <a href=@{SupplierR}>_{MsgSuppliers}
+      $if username /= "nobody"
+        <span>
+          <a href=@{AuthR LogoutR}>_{MsgLogout}
+    $nothing
+      <span>
+        <a href=@{AuthR LoginR}>_{MsgLogin}
     <div .right>
       ^{pageBody copyrightWidget}