diff --git a/Foundation.hs b/Foundation.hs index 3863084..231f29a 100644 --- a/Foundation.hs +++ b/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 --- type AuthId App = UserId +instance YesodAuth App where + type AuthId App = Text --- -- Where to send a user after successful login --- loginDest _ = HomeR --- -- Where to send a user after logout --- logoutDest _ = HomeR --- -- Override the above two destinations when a Referer: header is present --- redirectToReferer _ = True + -- Where to send a user after successful login + loginDest _ = HomeR + -- Where to send a user after logout + logoutDest _ = HomeR + -- Override the above two destinations when a Referer: header is present + redirectToReferer _ = True --- getAuthId creds = runDB $ do --- 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 --- } + -- getAuthId = return . Just . credsIdent --- -- You can add other plugins like BrowserID, email or OAuth here --- authPlugins _ = [authBrowserId def] + -- getAuthId creds = runDB $ do + -- 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 diff --git a/Handler/Common.hs b/Handler/Common.hs index ca86982..86779f7 100644 --- a/Handler/Common.hs +++ b/Handler/Common.hs @@ -34,8 +34,10 @@ import Import -- runtime dependency, and for efficiency. getFaviconR :: Handler TypedContent -getFaviconR = return $ TypedContent "image/x-icon" - $ toContent $(embedFile "config/favicon.ico") +getFaviconR = do + cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month + return $ TypedContent "image/x-icon" + $ toContent $(embedFile "config/favicon.ico") getRobotsR :: Handler TypedContent getRobotsR = return $ TypedContent typePlain diff --git a/Settings.hs b/Settings.hs index 1fc9077..169f0c3 100644 --- a/Settings.hs +++ b/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 diff --git a/config/routes b/config/routes index 84d7e5c..b899cf4 100644 --- a/config/routes +++ b/config/routes @@ -1,3 +1,4 @@ +/auth AuthR Auth getAuth /static StaticR Static appStatic /favicon.ico FaviconR GET diff --git a/config/settings.yml b/config/settings.yml index 0bfe998..4e737ec 100644 --- a/config/settings.yml +++ b/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" diff --git a/messages/cz.msg b/messages/cz.msg index c02c9d8..7d48041 100644 --- a/messages/cz.msg +++ b/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 diff --git a/messages/de.msg b/messages/de.msg index 4574002..871c4a6 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -143,3 +143,5 @@ CustomerId: Kundennummer TotalCrates: Gesamtanzahl Kästen Modify: bearbeiten UserIdentNotUnique: Benutzername ist nicht einzigartig +Login: Login +Logout: Logout diff --git a/messages/en.msg b/messages/en.msg index f6b3b44..b473664 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -143,3 +143,5 @@ CustomerId: Customer id TotalCrates: Total crates Modify: modify UserIdentNotUnique: Username is not unique +Login: Login +Logout: Logout diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet index 17f858e..f9ad78e 100644 --- a/templates/default-layout.hamlet +++ b/templates/default-layout.hamlet @@ -26,15 +26,22 @@