Added development mode.

.gitignore

@@ -19,4 +19,4 @@ cabal.sandbox.config
 *~
 \#*
 TAGS
-Cirkeltrek.cabal
\ No newline at end of file
+*.cabal

Cirkeltrek.cabal

@@ -2,7 +2,7 @@
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: ac82d237ef701a1dbc867cec1e99eb5d5bb8ad007265c41dc76968c2c000666f
+-- hash: fd7a7246f0613d88e47e6f2e5ce057afc082ed5215a32651d8e7e52850604853
 
 name:           Cirkeltrek
 version:        0.0.0
@@ -26,6 +26,7 @@ library
     , base
     , classy-prelude
     , classy-prelude-yesod
+    , data-default
     , esqueleto
     , fast-logger
     , file-embed
@@ -63,6 +64,7 @@ executable Cirkeltrek
     , base
     , classy-prelude
     , classy-prelude-yesod
+    , data-default
     , esqueleto
     , fast-logger
     , file-embed

app/Main.hs

-import Application (newMain) -- for YesodDispatch instance
-import Foundation
-import Yesod.Core
+import           Application (newMain)
+import           Foundation
+import           Yesod.Core
 
 main :: IO ()
 main = newMain

app/devel.hs

+{-# LANGUAGE PackageImports #-}
+import           "Cirkeltrek" Application (develMain)
+import           Prelude                  (IO)
+
+main = develMain

package.yaml

@@ -6,6 +6,7 @@ dependencies:
 - aeson
 - classy-prelude
 - classy-prelude-yesod
+- data-default
 - esqueleto
 - fast-logger
 - file-embed

src/Application.hs

 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude     #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE QuasiQuotes           #-}
 {-# LANGUAGE RecordWildCards       #-}
@@ -7,22 +8,27 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Application where
 
+import           ClassyPrelude.Yesod
+
 import           Control.Monad
 import           Control.Monad.Logger
 import           Database.Persist.Postgresql
 import           Foundation
 import           Language.Haskell.TH.Syntax
 import           Network.HTTP.Client.TLS
+import           Network.Wai                          (Middleware)
 import           Network.Wai.Handler.Warp
+import           Network.Wai.Middleware.RequestLogger
 import           System.Log.FastLogger
 import           Yesod.Core
+import           Yesod.Core.Types                     (loggerSet)
 import           Yesod.Default.Config2
 import           Yesod.Static
 
 import           Home
 import           Model
-import           Settings                    (ApplicationSettings (..),
-                                              configSettingsYmlValue)
+import           Settings                             (ApplicationSettings (..),
+                                                       configSettingsYmlValue)
 
 mkYesodDispatch "App" resourcesApp
 
@@ -63,10 +69,22 @@ warpSettings app =
          (toLogStr $ "Exception from warp: " ++ show exception))
     defaultSettings
 
+makeLogware :: App -> IO Middleware
+makeLogware app = do
+  mkRequestLogger
+    def
+    { outputFormat =
+        if appDetailedRequestLogging $ appSettings app
+          then Detailed True
+          else Apache FromFallback
+    , destination = Logger $ loggerSet $ appLogger app
+    }
+
 makeApplication :: App -> IO Application
 makeApplication app = do
+  logware <- makeLogware app
   commonapp <- toWaiApp app
-  return $ defaultMiddlewaresNoLogging commonapp
+  return $ logware $ defaultMiddlewaresNoLogging commonapp
 
 newMain :: IO ()
 newMain = do
@@ -74,3 +92,19 @@ newMain = do
   app <- makeFoundation settings
   commonapp <- makeApplication app
   runSettings (warpSettings app) commonapp
+
+-- DEVEL
+
+getAppSettings :: IO ApplicationSettings
+getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv
+
+getAppDev :: IO (Settings, Application)
+getAppDev = do
+  settings <- getAppSettings
+  found <- makeFoundation settings
+  warpsettings <- getDevSettings $ warpSettings found
+  app <- makeApplication found
+  return (warpsettings, app)
+
+develMain :: IO ()
+develMain = develMainHelper getAppDev

src/Foundation.hs

-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE RankNTypes        #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE TypeFamilies      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude     #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeFamilies          #-}
 
 module Foundation where
 
@@ -13,11 +14,15 @@ import           ClassyPrelude.Yesod
 import           Database.Persist.Sql
 import           Network.HTTP.Client
 import           Text.Hamlet
+import           Yesod.Auth
+import           Yesod.Auth.HashDB
+import           Yesod.Auth.Message
 import           Yesod.Core
 import           Yesod.Core.Types
 import           Yesod.Form
 import           Yesod.Static
 
+import           Model
 import           Settings
 
 data App = App
@@ -53,7 +58,7 @@ instance Yesod App where
         $maybe route <- mcurrentroute
           <p> You're at #{show route}.
         $nothing
-          <p> You're lost.
+          <p> Apparently you're lost.
         ^{widget}
       |]
     withUrlRenderer $(hamletFile "templates/wrapper.hamlet")
@@ -64,3 +69,19 @@ instance YesodPersist App where
     master <- getYesod
     runSqlPool action $ appConnectionPool master
 
+instance RenderMessage App FormMessage where
+  renderMessage _ _ = defaultFormMessage
+
+instance YesodAuth App where
+  type AuthId App = UsersId
+  loginDest _ = HomeR
+  logoutDest _ = HomeR
+  redirectToReferer _ = False
+  authPlugins _ = [authHashDB (Just . UniqueUsername)]
+  authenticate creds = liftHandler $ runDB $ do
+    x <- getBy $ UniqueUsername $ credsIdent creds
+    case x of
+      Nothing             -> return $ UserError InvalidLogin
+      Just (Entity uid _) -> return $ Authenticated uid
+
+instance YesodAuthPersist App

src/Model.hs

@@ -4,7 +4,7 @@
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE NoImplicitParams           #-}
+{-# LANGUAGE NoImplicitPrelude          #-}
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE QuasiQuotes                #-}
 {-# LANGUAGE TemplateHaskell            #-}
@@ -13,6 +13,7 @@ module Model where
 
 import           ClassyPrelude.Yesod
 import           Database.Persist.TH
+import           Yesod.Auth.HashDB
 
 import           Model.Grouping
 
@@ -94,3 +95,7 @@ share
       zappedBy UsersId Maybe
       deriving Show Eq
   |]
+
+instance HashDBUser Users where
+  userPasswordHash = usersPassword
+  setPasswordHash h u = u {usersPassword = Just h}