Merge branch '5-scaffolding-aufraumen' into 'master'

Resolve "Scaffolding aufräumen"

Closes #5

See merge request !1

.gitignore

@@ -1,7 +1,7 @@
 dist*
 static/tmp/
 static/combined/
-config/client_session_key.aes
+client_session_key.aes
 *.hi
 *.o
 *.sqlite3

package.yaml

@@ -45,6 +45,10 @@ dependencies:
 - time
 - case-insensitive
 - wai
+- cryptonite
+- cryptonite-conduit
+- base64-bytestring
+- memory
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

routes

@@ -6,6 +6,4 @@
 
 / HomeR GET POST
 
-/comments CommentR POST
-
 /profile ProfileR GET

src/Application.hs

@@ -40,19 +40,18 @@ import System.Log.FastLogger                (defaultBufSize, newStdoutLoggerSet,
 -- Don't forget to add new modules to your cabal file!
 import Handler.Common
 import Handler.Home
-import Handler.Comment
 import Handler.Profile
 
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
 -- comments there for more details.
-mkYesodDispatch "App" resourcesApp
+mkYesodDispatch "UniWorX" resourcesUniWorX
 
 -- | This function allocates resources (such as a database connection pool),
 -- performs initialization and returns a foundation datatype value. This is also
 -- the place to put your migrate statements to have automatic database
 -- migrations handled by Yesod.
-makeFoundation :: AppSettings -> IO App
+makeFoundation :: AppSettings -> IO UniWorX
 makeFoundation appSettings = do
     -- Some basic initializations: HTTP connection manager, logger, and static
     -- subsite.
@@ -67,8 +66,8 @@ makeFoundation appSettings = do
     -- logging function. To get out of this loop, we initially create a
     -- temporary foundation without a real connection pool, get a log function
     -- from there, and then create the real foundation.
-    let mkFoundation appConnPool = App {..}
-        -- The App {..} syntax is an example of record wild cards. For more
+    let mkFoundation appConnPool = UniWorX {..}
+        -- The UniWorX {..} syntax is an example of record wild cards. For more
         -- information, see:
         -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
         tempFoundation = mkFoundation $ error "connPool forced in tempFoundation"
@@ -87,14 +86,14 @@ makeFoundation appSettings = do
 
 -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
 -- applying some additional middlewares.
-makeApplication :: App -> IO Application
+makeApplication :: UniWorX -> IO Application
 makeApplication foundation = do
     logWare <- makeLogWare foundation
     -- Create the WAI application and apply middlewares
     appPlain <- toWaiAppPlain foundation
     return $ logWare $ defaultMiddlewaresNoLogging appPlain
 
-makeLogWare :: App -> IO Middleware
+makeLogWare :: UniWorX -> IO Middleware
 makeLogWare foundation =
     mkRequestLogger def
         { outputFormat =
@@ -109,7 +108,7 @@ makeLogWare foundation =
 
 
 -- | Warp settings for the given foundation value.
-warpSettings :: App -> Settings
+warpSettings :: UniWorX -> Settings
 warpSettings foundation =
       setPort (appPort $ appSettings foundation)
     $ setHost (appHost $ appSettings foundation)
@@ -126,14 +125,14 @@ warpSettings foundation =
 -- | For yesod devel, return the Warp settings and WAI Application.
 getApplicationDev :: IO (Settings, Application)
 getApplicationDev = do
-    settings <- getAppSettings
+    settings <- getAppDevSettings
     foundation <- makeFoundation settings
     wsettings <- getDevSettings $ warpSettings foundation
     app <- makeApplication foundation
     return (wsettings, app)
 
-getAppSettings :: IO AppSettings
-getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv
+getAppDevSettings :: IO AppSettings
+getAppDevSettings = loadYamlSettings [".dbsettings.yml", "config/test-settings.yml", configSettingsYml] [configSettingsYmlValue] useEnv
 
 -- | main function for use by yesod devel
 develMain :: IO ()
@@ -163,15 +162,15 @@ appMain = do
 --------------------------------------------------------------
 -- Functions for DevelMain.hs (a way to run the app from GHCi)
 --------------------------------------------------------------
-getApplicationRepl :: IO (Int, App, Application)
+getApplicationRepl :: IO (Int, UniWorX, Application)
 getApplicationRepl = do
-    settings <- getAppSettings
+    settings <- getAppDevSettings
     foundation <- makeFoundation settings
     wsettings <- getDevSettings $ warpSettings foundation
     app1 <- makeApplication foundation
     return (getPort wsettings, foundation, app1)
 
-shutdownApp :: App -> IO ()
+shutdownApp :: UniWorX -> IO ()
 shutdownApp _ = return ()
 
 
@@ -181,8 +180,8 @@ shutdownApp _ = return ()
 
 -- | Run a handler
 handler :: Handler a -> IO a
-handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h
+handler h = getAppDevSettings >>= makeFoundation >>= flip unsafeHandler h
 
 -- | Run DB queries
-db :: ReaderT SqlBackend (HandlerT App IO) a -> IO a
+db :: ReaderT SqlBackend (HandlerT UniWorX IO) a -> IO a
 db = handler . runDB

src/Foundation.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DataKinds #-}
 
 module Foundation where
 
@@ -22,11 +23,26 @@ import qualified Yesod.Core.Unsafe as Unsafe
 import qualified Data.CaseInsensitive as CI
 import qualified Data.Text.Encoding as TE
 
+import Data.ByteArray (convert)
+import Crypto.Hash (Digest, SHAKE256)
+import Crypto.Hash.Conduit (sinkHash)
+
+import qualified Data.ByteString.Base64.URL as Base64 (encode)
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy as Lazy.ByteString
+
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+
+import Data.Conduit (($$))
+import Data.Conduit.List (sourceList)
+
 -- | The foundation datatype for your application. This can be a good place to
 -- keep settings and values requiring initialization before your application
 -- starts running, such as database connections. Every handler will have
 -- access to the data present here.
-data App = App
+data UniWorX = UniWorX
     { appSettings    :: AppSettings
     , appStatic      :: Static -- ^ Settings for static file serving.
     , appConnPool    :: ConnectionPool -- ^ Database connection pool.
@@ -36,7 +52,7 @@ data App = App
 
 data MenuItem = MenuItem
     { menuItemLabel :: Text
-    , menuItemRoute :: Route App
+    , menuItemRoute :: Route UniWorX
     , menuItemAccessCallback :: Bool
     }
 
@@ -54,16 +70,16 @@ data MenuTypes
 -- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules
 --
 -- This function also generates the following type synonyms:
--- type Handler = HandlerT App IO
--- type Widget = WidgetT App IO ()
-mkYesodData "App" $(parseRoutesFile "config/routes")
+-- type Handler = HandlerT UniWorX IO
+-- type Widget = WidgetT UniWorX IO ()
+mkYesodData "UniWorX" $(parseRoutesFile "routes")
 
 -- | A convenient synonym for creating forms.
-type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
+type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
 
 -- Please see the documentation for the Yesod typeclass. There are a number
 -- of settings which can be configured by overriding methods here.
-instance Yesod App where
+instance Yesod UniWorX where
     -- Controls the base of generated URLs. For more information on modifying,
     -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
     approot = ApprootRequest $ \app req ->
@@ -75,7 +91,7 @@ instance Yesod App where
     -- default session idle timeout is 120 minutes
     makeSessionBackend _ = Just <$> defaultClientSessionBackend
         120    -- timeout in minutes
-        "config/client_session_key.aes"
+        "client_session_key.aes"
 
     -- Yesod Middleware allows you to run code before and after each handler function.
     -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
@@ -142,7 +158,6 @@ instance Yesod App where
 
     -- Routes not requiring authentication.
     isAuthorized (AuthR _) _ = return Authorized
-    isAuthorized CommentR _ = return Authorized
     isAuthorized HomeR _ = return Authorized
     isAuthorized FaviconR _ = return Authorized
     isAuthorized RobotsR _ = return Authorized
@@ -166,8 +181,19 @@ instance Yesod App where
             mime
             content
       where
-        -- Generate a unique filename based on the content itself
-        genFileName lbs = "autogen-" ++ base64md5 lbs
+        -- Generate a unique filename based on the content itself, this is used
+        -- for deduplication so a collision resistant hash function is required
+        --
+        -- SHA-3 (SHAKE256) seemed to be a future-proof choice
+        --
+        -- Length of hash is 144 bits instead of MD5's 128, so as to avoid
+        -- padding after base64-conversion
+        genFileName lbs = Text.unpack
+                        . Text.decodeUtf8
+                        . Base64.encode
+                        . (convert :: Digest (SHAKE256 144) -> ByteString)
+                        . runIdentity
+                        $ sourceList (Lazy.ByteString.toChunks lbs) $$ sinkHash
 
     -- What messages should be logged. The following includes all messages when
     -- in development, and warnings and errors in production.
@@ -179,23 +205,21 @@ instance Yesod App where
     makeLogger = return . appLogger
 
 -- Define breadcrumbs.
-instance YesodBreadcrumbs App where
+instance YesodBreadcrumbs UniWorX where
   breadcrumb HomeR = return ("Home", Nothing)
   breadcrumb (AuthR _) = return ("Login", Just HomeR)
   breadcrumb ProfileR = return ("Profile", Just HomeR)
   breadcrumb  _ = return ("home", Nothing)
 
 -- How to run database actions.
-instance YesodPersist App where
-    type YesodPersistBackend App = SqlBackend
-    runDB action = do
-        master <- getYesod
-        runSqlPool action $ appConnPool master
-instance YesodPersistRunner App where
+instance YesodPersist UniWorX where
+    type YesodPersistBackend UniWorX = SqlBackend
+    runDB action = runSqlPool action =<< appConnPool <$> getYesod
+instance YesodPersistRunner UniWorX where
     getDBRunner = defaultGetDBRunner appConnPool
 
-instance YesodAuth App where
-    type AuthId App = UserId
+instance YesodAuth UniWorX where
+    type AuthId UniWorX = UserId
 
     -- Where to send a user after successful login
     loginDest _ = HomeR
@@ -228,20 +252,20 @@ isAuthenticated = do
         Nothing -> Unauthorized "You must login to access this page"
         Just _ -> Authorized
 
-instance YesodAuthPersist App
+instance YesodAuthPersist UniWorX
 
 -- This instance is required to use forms. You can modify renderMessage to
 -- achieve customized and internationalized form validation messages.
-instance RenderMessage App FormMessage where
+instance RenderMessage UniWorX FormMessage where
     renderMessage _ _ = defaultFormMessage
 
 -- Useful when writing code that is re-usable outside of the Handler context.
 -- An example is background jobs that send email.
 -- This can also be useful for writing code that works across multiple Yesod applications.
-instance HasHttpManager App where
+instance HasHttpManager UniWorX where
     getHttpManager = appHttpManager
 
-unsafeHandler :: App -> Handler a -> IO a
+unsafeHandler :: UniWorX -> Handler a -> IO a
 unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
 
 -- Note: Some functionality previously present in the scaffolding has been

src/Handler/Comment.hs

@@ -1,16 +0,0 @@
-module Handler.Comment where
-
-import Import
-
-postCommentR :: Handler Value
-postCommentR = do
-    -- requireJsonBody will parse the request body into the appropriate type, or return a 400 status code if the request JSON is invalid.
-    -- (The ToJSON and FromJSON instances are derived in the config/models file).
-    comment <- (requireJsonBody :: Handler Comment)
-
-    -- The YesodAuth instance in Foundation.hs defines the UserId to be the type used for authentication.
-    maybeCurrentUserId <- maybeAuthId
-    let comment' = comment { commentUserId = maybeCurrentUserId }
-
-    insertedComment <- runDB $ insertEntity comment'
-    returnJson insertedComment

src/Handler/Common.hs

@@ -15,8 +15,8 @@ import Import
 getFaviconR :: Handler TypedContent
 getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month
                  return $ TypedContent "image/x-icon"
-                        $ toContent $(embedFile "config/favicon.ico")
+                        $ toContent $(embedFile "embedded/favicon.ico")
 
 getRobotsR :: Handler TypedContent
 getRobotsR = return $ TypedContent typePlain
-                    $ toContent $(embedFile "config/robots.txt")
+                    $ toContent $(embedFile "embedded/robots.txt")

src/Import.hs

@@ -4,4 +4,3 @@ module Import
 
 import Foundation            as Import
 import Import.NoFoundation   as Import
-import ModelData             as Import

src/Model.hs

@@ -7,20 +7,23 @@
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE TemplateHaskell            #-}
 {-# LANGUAGE TypeFamilies               #-}
-module Model where
+module Model
+  ( module Model
+  , module Model.Types
+  ) where
 
 import ClassyPrelude.Yesod
 import Database.Persist.Quasi
 -- import Data.Time
 -- import Data.ByteString
-import ModelData
+import Model.Types
 
 -- You can define all of your database entities in the entities file.
 -- You can find more information on persistent and how to declare entities
 -- at:
 -- http://www.yesodweb.com/book/persistent/
 share [mkPersist sqlSettings, mkMigrate "migrateAll"]
-    $(persistFileWith lowerCaseSettings "config/models")
+    $(persistFileWith lowerCaseSettings "models")
 
 instance Show Term where
   show = ClassyPrelude.Yesod.unpack . termName

src/Model/Types.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE TemplateHaskell #-}
-module ModelData where
+module Model.Types where
 
 import Database.Persist.TH
 
@@ -28,4 +28,4 @@ instance PersistField Term where
 	fromPersistValue (Term {season, year}) = undefined
 	sqlType _ = SqlInteger
 	isNullable _ = False
--}
+-}

templates/homepage.julius

@@ -13,7 +13,7 @@ $(function() {
 
     // Make an AJAX request to the server to create a new comment
     $.ajax({
-      url: '@{CommentR}',
+      url: 'null.invalid',
       type: 'POST',
       contentType: "application/json",
       data: JSON.stringify({

test/Handler/CommentSpec.hs

@@ -1,43 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Handler.CommentSpec (spec) where
-
-import TestImport
-import Data.Aeson
-
-spec :: Spec
-spec = withApp $ do
-    describe "valid request" $ do
-        it "gives a 200" $ do
-            get HomeR
-            statusIs 200
-
-            let message = "My message" :: Text
-                body = object [ "message" .= message ]
-                encoded = encode body
-
-            request $ do
-                setMethod "POST"
-                setUrl CommentR
-                setRequestBody encoded
-                addRequestHeader ("Content-Type", "application/json")
-
-            statusIs 200
-
-            [Entity _id comment] <- runDB $ selectList [CommentMessage ==. message] []
-            assertEq "Should have " comment (Comment message Nothing)
-
-    describe "invalid requests" $ do
-        it "400s when the JSON body is invalid" $ do
-            get HomeR
-
-            let body = object [ "foo" .= ("My message" :: Value) ]
-
-            request $ do
-                setMethod "POST"
-                setUrl CommentR
-                setRequestBody $ encode body
-                addRequestHeader ("Content-Type", "application/json")
-
-            statusIs 400
-

test/TestImport.hs

@@ -19,24 +19,24 @@ import Yesod.Auth            as X
 import Yesod.Test            as X
 import Yesod.Core.Unsafe     (fakeHandlerGetLogger)
 
-runDB :: SqlPersistM a -> YesodExample App a
+runDB :: SqlPersistM a -> YesodExample UniWorX a
 runDB query = do
     app <- getTestYesod
     liftIO $ runDBWithApp app query
 
-runDBWithApp :: App -> SqlPersistM a -> IO a
+runDBWithApp :: UniWorX -> SqlPersistM a -> IO a
 runDBWithApp app query = runSqlPersistMPool query (appConnPool app)
 
-runHandler :: Handler a -> YesodExample App a
+runHandler :: Handler a -> YesodExample UniWorX a
 runHandler handler = do
     app <- getTestYesod
     fakeHandlerGetLogger appLogger app handler
 
 
-withApp :: SpecWith (TestApp App) -> Spec
+withApp :: SpecWith (TestApp UniWorX) -> Spec
 withApp = before $ do
     settings <- loadYamlSettings
-        ["config/test-settings.yml", "config/settings.yml"]
+        [".dbsettings.yml", "config/test-settings.yml", "config/settings.yml"]
         []
         useEnv
     foundation <- makeFoundation settings
@@ -47,7 +47,7 @@ withApp = before $ do
 -- This function will truncate all of the tables in your database.
 -- 'withApp' calls it before each test, creating a clean environment for each
 -- spec to run in.
-wipeDB :: App -> IO ()
+wipeDB :: UniWorX -> IO ()
 wipeDB app = runDBWithApp app $ do
     tables <- getTables
     sqlBackend <- ask
@@ -69,7 +69,7 @@ getTables = do
 -- | Authenticate as a user. This relies on the `auth-dummy-login: true` flag
 -- being set in test-settings.yaml, which enables dummy authentication in
 -- Foundation.hs
-authenticateAs :: Entity User -> YesodExample App ()
+authenticateAs :: Entity User -> YesodExample UniWorX ()
 authenticateAs (Entity _ u) = do
     request $ do
         setMethod "POST"
@@ -78,7 +78,7 @@ authenticateAs (Entity _ u) = do
 
 -- | Create a user.  The dummy email entry helps to confirm that foreign-key
 -- checking is switched off in wipeDB for those database backends which need it.
-createUser :: Text -> YesodExample App (Entity User)
+createUser :: Text -> YesodExample UniWorX (Entity User)
 createUser ident = runDB $ do
     user <- insertEntity User
         { userIdent = ident