From bb2dbc3b79053b2ac1a056fbea172735e0e26e2a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 4 Oct 2017 13:59:49 +0200 Subject: [PATCH 1/8] Move files around --- .gitignore | 2 +- {config => app}/models | 0 {config => app}/routes | 2 -- {config => embedded}/favicon.ico | Bin {config => embedded}/robots.txt | 0 {app => exe}/DevelMain.hs | 0 {app => exe}/devel.hs | 0 {app => exe}/main.hs | 0 package.yaml | 2 +- src/Foundation.hs | 4 ++-- src/Handler/Comment.hs | 16 ---------------- src/Handler/Common.hs | 4 ++-- src/Import.hs | 1 - src/Model.hs | 9 ++++++--- src/{ModelData.hs => Model/Types.hs} | 4 ++-- 15 files changed, 14 insertions(+), 30 deletions(-) rename {config => app}/models (100%) rename {config => app}/routes (86%) rename {config => embedded}/favicon.ico (100%) rename {config => embedded}/robots.txt (100%) rename {app => exe}/DevelMain.hs (100%) rename {app => exe}/devel.hs (100%) rename {app => exe}/main.hs (100%) delete mode 100644 src/Handler/Comment.hs rename src/{ModelData.hs => Model/Types.hs} (96%) diff --git a/.gitignore b/.gitignore index 99d4a3d3c..5c3dfb89e 100644 --- a/.gitignore +++ b/.gitignore @@ -1,7 +1,7 @@ dist* static/tmp/ static/combined/ -config/client_session_key.aes +client_session_key.aes *.hi *.o *.sqlite3 diff --git a/config/models b/app/models similarity index 100% rename from config/models rename to app/models diff --git a/config/routes b/app/routes similarity index 86% rename from config/routes rename to app/routes index d6836884c..6df7b740c 100644 --- a/config/routes +++ b/app/routes @@ -6,6 +6,4 @@ / HomeR GET POST -/comments CommentR POST - /profile ProfileR GET diff --git a/config/favicon.ico b/embedded/favicon.ico similarity index 100% rename from config/favicon.ico rename to embedded/favicon.ico diff --git a/config/robots.txt b/embedded/robots.txt similarity index 100% rename from config/robots.txt rename to embedded/robots.txt diff --git a/app/DevelMain.hs b/exe/DevelMain.hs similarity index 100% rename from app/DevelMain.hs rename to exe/DevelMain.hs diff --git a/app/devel.hs b/exe/devel.hs similarity index 100% rename from app/devel.hs rename to exe/devel.hs diff --git a/app/main.hs b/exe/main.hs similarity index 100% rename from app/main.hs rename to exe/main.hs diff --git a/package.yaml b/package.yaml index 3830186c9..d9a41d8e0 100644 --- a/package.yaml +++ b/package.yaml @@ -68,7 +68,7 @@ library: executables: uniworx: main: main.hs - source-dirs: app + source-dirs: exe ghc-options: - -threaded - -rtsopts diff --git a/src/Foundation.hs b/src/Foundation.hs index 9979e7bb6..664a5e1b0 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -56,7 +56,7 @@ data MenuTypes -- This function also generates the following type synonyms: -- type Handler = HandlerT App IO -- type Widget = WidgetT App IO () -mkYesodData "App" $(parseRoutesFile "config/routes") +mkYesodData "App" $(parseRoutesFile "app/routes") -- | A convenient synonym for creating forms. type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget) @@ -75,7 +75,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. diff --git a/src/Handler/Comment.hs b/src/Handler/Comment.hs deleted file mode 100644 index edb20a8ab..000000000 --- a/src/Handler/Comment.hs +++ /dev/null @@ -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 diff --git a/src/Handler/Common.hs b/src/Handler/Common.hs index 6783f8afb..2119bfb06 100644 --- a/src/Handler/Common.hs +++ b/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") diff --git a/src/Import.hs b/src/Import.hs index 25ed1f7be..a10200156 100644 --- a/src/Import.hs +++ b/src/Import.hs @@ -4,4 +4,3 @@ module Import import Foundation as Import import Import.NoFoundation as Import -import ModelData as Import diff --git a/src/Model.hs b/src/Model.hs index c84945443..b3cd1712b 100644 --- a/src/Model.hs +++ b/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 "app/models") instance Show Term where show = ClassyPrelude.Yesod.unpack . termName diff --git a/src/ModelData.hs b/src/Model/Types.hs similarity index 96% rename from src/ModelData.hs rename to src/Model/Types.hs index 620feff5c..be40723b9 100644 --- a/src/ModelData.hs +++ b/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 --} \ No newline at end of file +-} From b058fd84babd46f975cbef1a3502d160555a266e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 4 Oct 2017 13:59:58 +0200 Subject: [PATCH 2/8] Drop Handler.Comment --- src/Application.hs | 1 - src/Foundation.hs | 1 - templates/homepage.julius | 2 +- 3 files changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 8017d6f07..76d4c3480 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -40,7 +40,6 @@ 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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 664a5e1b0..7f1329238 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -142,7 +142,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 diff --git a/templates/homepage.julius b/templates/homepage.julius index 865882ec9..c04a285e6 100644 --- a/templates/homepage.julius +++ b/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({ From 2d2b1a2ed346027eb882e4095272ad42fb15adec Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 4 Oct 2017 14:12:19 +0200 Subject: [PATCH 3/8] Fix file structure for `yesod devel` --- {exe => app}/DevelMain.hs | 0 {exe => app}/devel.hs | 0 {exe => app}/main.hs | 0 app/models => models | 0 package.yaml | 2 +- app/routes => routes | 0 src/Foundation.hs | 2 +- src/Model.hs | 2 +- 8 files changed, 3 insertions(+), 3 deletions(-) rename {exe => app}/DevelMain.hs (100%) rename {exe => app}/devel.hs (100%) rename {exe => app}/main.hs (100%) rename app/models => models (100%) rename app/routes => routes (100%) diff --git a/exe/DevelMain.hs b/app/DevelMain.hs similarity index 100% rename from exe/DevelMain.hs rename to app/DevelMain.hs diff --git a/exe/devel.hs b/app/devel.hs similarity index 100% rename from exe/devel.hs rename to app/devel.hs diff --git a/exe/main.hs b/app/main.hs similarity index 100% rename from exe/main.hs rename to app/main.hs diff --git a/app/models b/models similarity index 100% rename from app/models rename to models diff --git a/package.yaml b/package.yaml index d9a41d8e0..3830186c9 100644 --- a/package.yaml +++ b/package.yaml @@ -68,7 +68,7 @@ library: executables: uniworx: main: main.hs - source-dirs: exe + source-dirs: app ghc-options: - -threaded - -rtsopts diff --git a/app/routes b/routes similarity index 100% rename from app/routes rename to routes diff --git a/src/Foundation.hs b/src/Foundation.hs index 7f1329238..8ae8a28c7 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -56,7 +56,7 @@ data MenuTypes -- This function also generates the following type synonyms: -- type Handler = HandlerT App IO -- type Widget = WidgetT App IO () -mkYesodData "App" $(parseRoutesFile "app/routes") +mkYesodData "App" $(parseRoutesFile "routes") -- | A convenient synonym for creating forms. type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget) diff --git a/src/Model.hs b/src/Model.hs index b3cd1712b..dedba802f 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -23,7 +23,7 @@ import Model.Types -- at: -- http://www.yesodweb.com/book/persistent/ share [mkPersist sqlSettings, mkMigrate "migrateAll"] - $(persistFileWith lowerCaseSettings "app/models") + $(persistFileWith lowerCaseSettings "models") instance Show Term where show = ClassyPrelude.Yesod.unpack . termName From e2e6ab37983b4ce3b15a2440e433bf1f457dfd95 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 4 Oct 2017 14:12:27 +0200 Subject: [PATCH 4/8] Have yesod load correct config files when developing --- src/Application.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 76d4c3480..62a9cc3c5 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -125,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 () @@ -164,7 +164,7 @@ appMain = do -------------------------------------------------------------- getApplicationRepl :: IO (Int, App, Application) getApplicationRepl = do - settings <- getAppSettings + settings <- getAppDevSettings foundation <- makeFoundation settings wsettings <- getDevSettings $ warpSettings foundation app1 <- makeApplication foundation @@ -180,7 +180,7 @@ 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 From ef3be262aa4a6ca18a755853c8826f9b54392dd8 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 4 Oct 2017 14:17:10 +0200 Subject: [PATCH 5/8] Rename foundation type --- src/Application.hs | 20 ++++++++++---------- src/Foundation.hs | 34 +++++++++++++++++----------------- 2 files changed, 27 insertions(+), 27 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 62a9cc3c5..a810dc36a 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -45,13 +45,13 @@ 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. @@ -66,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" @@ -86,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 = @@ -108,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) @@ -162,7 +162,7 @@ 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 <- getAppDevSettings foundation <- makeFoundation settings @@ -170,7 +170,7 @@ getApplicationRepl = do app1 <- makeApplication foundation return (getPort wsettings, foundation, app1) -shutdownApp :: App -> IO () +shutdownApp :: UniWorX -> IO () shutdownApp _ = return () @@ -183,5 +183,5 @@ handler :: Handler a -> IO a 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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 8ae8a28c7..2bd8a86b3 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -26,7 +26,7 @@ import qualified Data.Text.Encoding as TE -- 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 +36,7 @@ data App = App data MenuItem = MenuItem { menuItemLabel :: Text - , menuItemRoute :: Route App + , menuItemRoute :: Route UniWorX , menuItemAccessCallback :: Bool } @@ -54,16 +54,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 "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 -> @@ -178,23 +178,23 @@ 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 +instance YesodPersist UniWorX where + type YesodPersistBackend UniWorX = SqlBackend runDB action = do master <- getYesod runSqlPool action $ appConnPool master -instance YesodPersistRunner App where +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 @@ -227,20 +227,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 From 76aa7da3ab7878a7fd49926b9f3fe89834c8f1fd Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 4 Oct 2017 14:33:59 +0200 Subject: [PATCH 6/8] =?UTF-8?q?Fix=20generation=20of=20temporary=20files?= =?UTF-8?q?=C2=B4=20names?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- package.yaml | 4 ++++ src/Foundation.hs | 31 +++++++++++++++++++++++++++++-- 2 files changed, 33 insertions(+), 2 deletions(-) diff --git a/package.yaml b/package.yaml index 3830186c9..13da5a6b4 100644 --- a/package.yaml +++ b/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. diff --git a/src/Foundation.hs b/src/Foundation.hs index 2bd8a86b3..cfdceedea 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DataKinds #-} module Foundation where @@ -22,6 +23,21 @@ 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 @@ -165,8 +181,19 @@ instance Yesod UniWorX 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. From b86e60843f32d26a87ce93dbfaaafb72dd5d82f9 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 4 Oct 2017 14:38:09 +0200 Subject: [PATCH 7/8] Minor cleanup --- src/Foundation.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index cfdceedea..7936a916f 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -214,9 +214,7 @@ instance YesodBreadcrumbs UniWorX where -- How to run database actions. instance YesodPersist UniWorX where type YesodPersistBackend UniWorX = SqlBackend - runDB action = do - master <- getYesod - runSqlPool action $ appConnPool master + runDB action = runSqlPool action =<< appConnPool <$> getYesod instance YesodPersistRunner UniWorX where getDBRunner = defaultGetDBRunner appConnPool From fbc1ee52cac35f2baffd44cf90880fc0c8230a9a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 4 Oct 2017 14:48:23 +0200 Subject: [PATCH 8/8] Fix test suite --- test/Handler/CommentSpec.hs | 43 ------------------------------------- test/TestImport.hs | 16 +++++++------- 2 files changed, 8 insertions(+), 51 deletions(-) delete mode 100644 test/Handler/CommentSpec.hs diff --git a/test/Handler/CommentSpec.hs b/test/Handler/CommentSpec.hs deleted file mode 100644 index 0b5225cd8..000000000 --- a/test/Handler/CommentSpec.hs +++ /dev/null @@ -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 - diff --git a/test/TestImport.hs b/test/TestImport.hs index 66626ba0d..47cd584ad 100644 --- a/test/TestImport.hs +++ b/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