From 2765abfedc444bdf0ec5111408f8e5185fa3cff0 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 12 Jun 2017 08:13:26 +0300 Subject: [PATCH 1/2] Add hindent support and bash script --- .haskell-ghc-mod.json | 3 + .hindent.yaml | 3 + app/DevelMain.hs | 63 ++++++++-------- app/devel.hs | 1 + app/main.hs | 2 +- hindent_all | 32 ++++++++ src/Application.hs | 97 +++++++++++------------- src/Foundation.hs | 144 +++++++++++++----------------------- src/Handler/Comment.hs | 7 +- src/Handler/Common.hs | 11 ++- src/Handler/Home.hs | 30 +++----- src/Handler/Profile.hs | 1 + src/Import.hs | 4 +- src/Import/NoFoundation.hs | 13 ++-- src/Model.hs | 20 ++--- src/Settings/StaticFiles.hs | 5 +- test/Handler/CommentSpec.hs | 69 ++++++++--------- test/Handler/CommonSpec.hs | 29 ++++---- test/Handler/HomeSpec.hs | 50 ++++++------- test/Handler/ProfileSpec.hs | 43 ++++++----- test/TestImport.hs | 69 +++++++++-------- 21 files changed, 337 insertions(+), 359 deletions(-) create mode 100644 .haskell-ghc-mod.json create mode 100644 .hindent.yaml create mode 100755 hindent_all diff --git a/.haskell-ghc-mod.json b/.haskell-ghc-mod.json new file mode 100644 index 0000000..d9fce76 --- /dev/null +++ b/.haskell-ghc-mod.json @@ -0,0 +1,3 @@ +{ + "suppressErrors": true +} diff --git a/.hindent.yaml b/.hindent.yaml new file mode 100644 index 0000000..d28d833 --- /dev/null +++ b/.hindent.yaml @@ -0,0 +1,3 @@ +indent-size: 4 +line-length: 80 +force-trailing-newline: true diff --git a/app/DevelMain.hs b/app/DevelMain.hs index b327943..9505c32 100644 --- a/app/DevelMain.hs +++ b/app/DevelMain.hs @@ -27,19 +27,18 @@ -- -- There is more information about this approach, -- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci - module DevelMain where -import Prelude import Application (getApplicationRepl, shutdownApp) +import Prelude +import Control.Concurrent import Control.Exception (finally) import Control.Monad ((>=>)) -import Control.Concurrent import Data.IORef import Foreign.Store -import Network.Wai.Handler.Warp import GHC.Word +import Network.Wai.Handler.Warp -- | Start or restart the server. -- newStore is from foreign-store. @@ -47,53 +46,57 @@ import GHC.Word update :: IO () update = do mtidStore <- lookupStore tidStoreNum - case mtidStore of + case mtidStore -- no server running - Nothing -> do - done <- storeAction doneStore newEmptyMVar - tid <- start done - _ <- storeAction (Store tidStoreNum) (newIORef tid) - return () + of + Nothing -> do + done <- storeAction doneStore newEmptyMVar + tid <- start done + _ <- storeAction (Store tidStoreNum) (newIORef tid) + return () -- server is already running - Just tidStore -> restartAppInNewThread tidStore + Just tidStore -> restartAppInNewThread tidStore where doneStore :: Store (MVar ()) doneStore = Store 0 - -- shut the server down with killThread and wait for the done signal restartAppInNewThread :: Store (IORef ThreadId) -> IO () - restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do - killThread tid - withStore doneStore takeMVar - readStore doneStore >>= start - - + restartAppInNewThread tidStore = + modifyStoredIORef tidStore $ \tid -> do + killThread tid + withStore doneStore takeMVar + readStore doneStore >>= start -- | Start the server in a separate thread. - start :: MVar () -- ^ Written to when the thread is killed. - -> IO ThreadId + start :: + MVar () -- ^ Written to when the thread is killed. + -> IO ThreadId start done = do (port, site, app) <- getApplicationRepl - forkIO (finally (runSettings (setPort port defaultSettings) app) + forkIO + (finally + (runSettings (setPort port defaultSettings) app) -- Note that this implies concurrency -- between shutdownApp and the next app that is starting. -- Normally this should be fine - (putMVar done () >> shutdownApp site)) + (putMVar done () >> shutdownApp site)) -- | kill the server shutdown :: IO () shutdown = do mtidStore <- lookupStore tidStoreNum - case mtidStore of + case mtidStore -- no server running - Nothing -> putStrLn "no Yesod app running" - Just tidStore -> do - withStore tidStore $ readIORef >=> killThread - putStrLn "Yesod app is shutdown" + of + Nothing -> putStrLn "no Yesod app running" + Just tidStore -> do + withStore tidStore $ readIORef >=> killThread + putStrLn "Yesod app is shutdown" tidStoreNum :: Word32 tidStoreNum = 1 modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO () -modifyStoredIORef store f = withStore store $ \ref -> do - v <- readIORef ref - f v >>= writeIORef ref +modifyStoredIORef store f = + withStore store $ \ref -> do + v <- readIORef ref + f v >>= writeIORef ref diff --git a/app/devel.hs b/app/devel.hs index e11441b..c59b032 100644 --- a/app/devel.hs +++ b/app/devel.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PackageImports #-} + import "PROJECTNAME" Application (develMain) import Prelude (IO) diff --git a/app/main.hs b/app/main.hs index 4ffa93d..28a55b9 100644 --- a/app/main.hs +++ b/app/main.hs @@ -1,5 +1,5 @@ -import Prelude (IO) import Application (appMain) +import Prelude (IO) main :: IO () main = appMain diff --git a/hindent_all b/hindent_all new file mode 100755 index 0000000..f3a0992 --- /dev/null +++ b/hindent_all @@ -0,0 +1,32 @@ +#!/usr/bin/env bash + +set -e + +HINDENT=hindent +GIT=git + +LINE_LENGTH=200 + +function hindent_file { + filename="$1" + output_filename="${filename}.hindented" + # In hindent 0.5+, the style is hard-coded to johan-tibell + ${HINDENT} --style johan-tibell --line-length "${LINE_LENGTH}" < "${filename}" > "${output_filename}" + mv "${output_filename}" "${filename}" +} + +function list_haskell_files { + # TODO: Figure out if it's a Haskell file in a more reliable way, e.g. + # using `file`, or just running hindent on everything. + + # TODO: Exclude ./src/Settings.hs + ${GIT} ls-files './*.hs' +} + +function indent_everything { + for filename in $(list_haskell_files); do + hindent_file "${filename}" + done +} + +indent_everything diff --git a/src/Application.hs b/src/Application.hs index 8017d6f..18ed1a6 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -5,6 +5,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + module Application ( getApplicationDev , appMain @@ -19,28 +20,27 @@ module Application , db ) where -import Control.Monad.Logger (liftLoc, runLoggingT) -import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr, - pgPoolSize, runSqlPool) +import Control.Monad.Logger (liftLoc, runLoggingT) +import Database.Persist.Postgresql + (createPostgresqlPool, pgConnStr, pgPoolSize, runSqlPool) import Import -import Language.Haskell.TH.Syntax (qLocation) +import Language.Haskell.TH.Syntax (qLocation) import Network.Wai (Middleware) -import Network.Wai.Handler.Warp (Settings, defaultSettings, - defaultShouldDisplayException, - runSettings, setHost, - setOnException, setPort, getPort) -import Network.Wai.Middleware.RequestLogger (Destination (Logger), - IPAddrSource (..), - OutputFormat (..), destination, - mkRequestLogger, outputFormat) -import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, - toLogStr) +import Network.Wai.Handler.Warp + (Settings, defaultSettings, defaultShouldDisplayException, getPort, + runSettings, setHost, setOnException, setPort) +import Network.Wai.Middleware.RequestLogger + (Destination(Logger), IPAddrSource(..), OutputFormat(..), + destination, mkRequestLogger, outputFormat) +import System.Log.FastLogger + (defaultBufSize, newStdoutLoggerSet, toLogStr) + +import Handler.Comment -- Import all relevant handler modules here. -- 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 @@ -53,15 +53,17 @@ mkYesodDispatch "App" resourcesApp -- the place to put your migrate statements to have automatic database -- migrations handled by Yesod. makeFoundation :: AppSettings -> IO App -makeFoundation appSettings = do +makeFoundation appSettings -- Some basic initializations: HTTP connection manager, logger, and static -- subsite. + = do appHttpManager <- newManager appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger appStatic <- - (if appMutableStatic appSettings then staticDevel else static) - (appStaticDir appSettings) - + (if appMutableStatic appSettings + then staticDevel + else static) + (appStaticDir appSettings) -- We need a log function to create a connection pool. We need a connection -- pool to create our foundation. And we need our foundation to get a -- logging function. To get out of this loop, we initially create a @@ -73,15 +75,10 @@ makeFoundation appSettings = do -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html tempFoundation = mkFoundation $ error "connPool forced in tempFoundation" logFunc = messageLoggerSource tempFoundation appLogger - -- Create the database connection pool - pool <- flip runLoggingT logFunc $ createPostgresqlPool - (pgConnStr $ appDatabaseConf appSettings) - (pgPoolSize $ appDatabaseConf appSettings) - + pool <- flip runLoggingT logFunc $ createPostgresqlPool (pgConnStr $ appDatabaseConf appSettings) (pgPoolSize $ appDatabaseConf appSettings) -- Perform database migration using our application's logging settings. runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc - -- Return the foundation return $ mkFoundation pool @@ -96,32 +93,27 @@ makeApplication foundation = do makeLogWare :: App -> IO Middleware makeLogWare foundation = - mkRequestLogger def + mkRequestLogger + def { outputFormat = - if appDetailedRequestLogging $ appSettings foundation - then Detailed True - else Apache - (if appIpFromHeader $ appSettings foundation - then FromFallback - else FromSocket) + if appDetailedRequestLogging $ appSettings foundation + then Detailed True + else Apache + (if appIpFromHeader $ appSettings foundation + then FromFallback + else FromSocket) , destination = Logger $ loggerSet $ appLogger foundation } - -- | Warp settings for the given foundation value. warpSettings :: App -> Settings warpSettings foundation = - setPort (appPort $ appSettings foundation) - $ setHost (appHost $ appSettings foundation) - $ setOnException (\_req e -> - when (defaultShouldDisplayException e) $ messageLoggerSource - foundation - (appLogger foundation) - $(qLocation >>= liftLoc) - "yesod" - LevelError - (toLogStr $ "Exception from Warp: " ++ show e)) - defaultSettings + setPort (appPort $ appSettings foundation) $ + setHost (appHost $ appSettings foundation) $ + setOnException + (\_req e -> + when (defaultShouldDisplayException e) $ messageLoggerSource foundation (appLogger foundation) $(qLocation >>= liftLoc) "yesod" LevelError (toLogStr $ "Exception from Warp: " ++ show e)) + defaultSettings -- | For yesod devel, return the Warp settings and WAI Application. getApplicationDev :: IO (Settings, Application) @@ -141,25 +133,22 @@ develMain = develMainHelper getApplicationDev -- | The @main@ function for an executable running this site. appMain :: IO () -appMain = do +appMain -- Get the settings from all relevant sources - settings <- loadYamlSettingsArgs + = do + settings <- + loadYamlSettingsArgs -- fall back to compile-time values, set to [] to require values at runtime - [configSettingsYmlValue] - + [configSettingsYmlValue] -- allow environment variables to override - useEnv - + useEnv -- Generate the foundation from the settings foundation <- makeFoundation settings - -- Generate a WAI Application from the foundation app <- makeApplication foundation - -- Run the application with Warp runSettings (warpSettings foundation) app - -------------------------------------------------------------- -- Functions for DevelMain.hs (a way to run the app from GHCi) -------------------------------------------------------------- @@ -174,11 +163,9 @@ getApplicationRepl = do shutdownApp :: App -> IO () shutdownApp _ = return () - --------------------------------------------- -- Functions for use in development with GHCi --------------------------------------------- - -- | Run a handler handler :: Handler a -> IO a handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h diff --git a/src/Foundation.hs b/src/Foundation.hs index 3792361..8f668e7 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -3,33 +3,34 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} + module Foundation where -import Import.NoFoundation import Database.Persist.Sql (ConnectionPool, runSqlPool) -import Text.Hamlet (hamletFile) -import Text.Jasmine (minifym) +import Import.NoFoundation +import Text.Hamlet (hamletFile) +import Text.Jasmine (minifym) -- Used only when in "auth-dummy-login" setting is enabled. import Yesod.Auth.Dummy -import Yesod.Auth.OpenId (authOpenId, IdentifierType (Claimed)) -import Yesod.Default.Util (addStaticContentExternal) -import Yesod.Core.Types (Logger) -import qualified Yesod.Core.Unsafe as Unsafe import qualified Data.CaseInsensitive as CI import qualified Data.Text.Encoding as TE +import Yesod.Auth.OpenId (IdentifierType(Claimed), authOpenId) +import Yesod.Core.Types (Logger) +import qualified Yesod.Core.Unsafe as Unsafe +import Yesod.Default.Util (addStaticContentExternal) -- | 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 - { appSettings :: AppSettings - , appStatic :: Static -- ^ Settings for static file serving. - , appConnPool :: ConnectionPool -- ^ Database connection pool. + { appSettings :: AppSettings + , appStatic :: Static -- ^ Settings for static file serving. + , appConnPool :: ConnectionPool -- ^ Database connection pool. , appHttpManager :: Manager - , appLogger :: Logger + , appLogger :: Logger } data MenuItem = MenuItem @@ -61,20 +62,22 @@ type Form x = Html -> MForm (HandlerT App 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 App -- Controls the base of generated URLs. For more information on modifying, -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot - approot = ApprootRequest $ \app req -> - case appRoot $ appSettings app of - Nothing -> getApprootText guessApproot app req - Just root -> root - + where + approot = + ApprootRequest $ \app req -> + case appRoot $ appSettings app of + Nothing -> getApprootText guessApproot app req + Just root -> root -- Store session data on the client in encrypted cookies, -- default session idle timeout is 120 minutes - makeSessionBackend _ = Just <$> defaultClientSessionBackend - 120 -- timeout in minutes - "config/client_session_key.aes" - + makeSessionBackend _ = + Just <$> + defaultClientSessionBackend + 120 -- timeout in minutes + "config/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. -- Some users may also want to add the defaultCsrfMiddleware, which: @@ -83,61 +86,36 @@ instance Yesod App where -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package. yesodMiddleware = defaultYesodMiddleware - defaultLayout widget = do master <- getYesod mmsg <- getMessage - muser <- maybeAuthPair mcurrentRoute <- getCurrentRoute - -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. (title, parents) <- breadcrumbs - -- Define the menu items of the header. let menuItems = - [ NavbarLeft $ MenuItem - { menuItemLabel = "Home" - , menuItemRoute = HomeR - , menuItemAccessCallback = True - } - , NavbarLeft $ MenuItem - { menuItemLabel = "Profile" - , menuItemRoute = ProfileR - , menuItemAccessCallback = isJust muser - } - , NavbarRight $ MenuItem - { menuItemLabel = "Login" - , menuItemRoute = AuthR LoginR - , menuItemAccessCallback = isNothing muser - } - , NavbarRight $ MenuItem - { menuItemLabel = "Logout" - , menuItemRoute = AuthR LogoutR - , menuItemAccessCallback = isJust muser - } + [ NavbarLeft $ MenuItem {menuItemLabel = "Home", menuItemRoute = HomeR, menuItemAccessCallback = True} + , NavbarLeft $ MenuItem {menuItemLabel = "Profile", menuItemRoute = ProfileR, menuItemAccessCallback = isJust muser} + , NavbarRight $ MenuItem {menuItemLabel = "Login", menuItemRoute = AuthR LoginR, menuItemAccessCallback = isNothing muser} + , NavbarRight $ MenuItem {menuItemLabel = "Logout", menuItemRoute = AuthR LogoutR, menuItemAccessCallback = isJust muser} ] - let navbarLeftMenuItems = [x | NavbarLeft x <- menuItems] let navbarRightMenuItems = [x | NavbarRight x <- menuItems] - let navbarLeftFilteredMenuItems = [x | x <- navbarLeftMenuItems, menuItemAccessCallback x] let navbarRightFilteredMenuItems = [x | x <- navbarRightMenuItems, menuItemAccessCallback x] - -- We break up the default layout into two components: -- default-layout is the contents of the body tag, and -- default-layout-wrapper is the entire page. Since the final -- value passed to hamletToRepHtml cannot be a widget, this allows -- you to use normal widget features in default-layout. - - pc <- widgetToPageContent $ do - addStylesheet $ StaticR css_bootstrap_css - $(widgetFile "default-layout") + pc <- + widgetToPageContent $ do + addStylesheet $ StaticR css_bootstrap_css + $(widgetFile "default-layout") withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") - -- The page to be redirected to when authentication is required. authRoute _ = Just $ AuthR LoginR - -- Routes not requiring authentication. isAuthorized (AuthR _) _ = return Authorized isAuthorized CommentR _ = return Authorized @@ -145,9 +123,7 @@ instance Yesod App where isAuthorized FaviconR _ = return Authorized isAuthorized RobotsR _ = return Authorized isAuthorized (StaticR _) _ = return Authorized - isAuthorized ProfileR _ = isAuthenticated - -- This function creates static content files in the static folder -- and names them based on a hash of their content. This allows -- expiration dates to be set far in the future without worry of @@ -155,33 +131,21 @@ instance Yesod App where addStaticContent ext mime content = do master <- getYesod let staticDir = appStaticDir $ appSettings master - addStaticContentExternal - minifym - genFileName - staticDir - (StaticR . flip StaticRoute []) - ext - mime - content - where + addStaticContentExternal minifym genFileName staticDir (StaticR . flip StaticRoute []) ext mime content -- Generate a unique filename based on the content itself + where genFileName lbs = "autogen-" ++ base64md5 lbs - -- What messages should be logged. The following includes all messages when -- in development, and warnings and errors in production. - shouldLog app _source level = - appShouldLogAll (appSettings app) - || level == LevelWarn - || level == LevelError - + shouldLog app _source level = appShouldLogAll (appSettings app) || level == LevelWarn || level == LevelError makeLogger = return . appLogger -- Define breadcrumbs. instance YesodBreadcrumbs App where - breadcrumb HomeR = return ("Home", Nothing) - breadcrumb (AuthR _) = return ("Login", Just HomeR) - breadcrumb ProfileR = return ("Profile", Just HomeR) - breadcrumb _ = return ("home", Nothing) + 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 @@ -189,42 +153,39 @@ instance YesodPersist App where runDB action = do master <- getYesod runSqlPool action $ appConnPool master + instance YesodPersistRunner App where getDBRunner = defaultGetDBRunner appConnPool instance YesodAuth App where type AuthId App = UserId - -- 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 - - authenticate creds = runDB $ do - x <- getBy $ UniqueUser $ credsIdent creds - case x of - Just (Entity uid _) -> return $ Authenticated uid - Nothing -> Authenticated <$> insert User - { userIdent = credsIdent creds - , userPassword = Nothing - } - + authenticate creds = + runDB $ do + x <- getBy $ UniqueUser $ credsIdent creds + case x of + Just (Entity uid _) -> return $ Authenticated uid + Nothing -> Authenticated <$> insert User {userIdent = credsIdent creds, userPassword = Nothing} -- You can add other plugins like Google Email, email or OAuth here authPlugins app = [authOpenId Claimed []] ++ extraAuthPlugins -- Enable authDummy login if enabled. - where extraAuthPlugins = [authDummy | appAuthDummyLogin $ appSettings app] - + where + extraAuthPlugins = [authDummy | appAuthDummyLogin $ appSettings app] authHttpManager = getHttpManager -- | Access function to determine if a user is logged in. isAuthenticated :: Handler AuthResult isAuthenticated = do muid <- maybeAuthId - return $ case muid of - Nothing -> Unauthorized "You must login to access this page" - Just _ -> Authorized + return $ + case muid of + Nothing -> Unauthorized "You must login to access this page" + Just _ -> Authorized instance YesodAuthPersist App @@ -241,7 +202,6 @@ instance HasHttpManager App where unsafeHandler :: App -> Handler a -> IO a unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger - -- Note: Some functionality previously present in the scaffolding has been -- moved to documentation in the Wiki. Following are some hopefully helpful -- links: diff --git a/src/Handler/Comment.hs b/src/Handler/Comment.hs index edb20a8..16a3d48 100644 --- a/src/Handler/Comment.hs +++ b/src/Handler/Comment.hs @@ -3,14 +3,13 @@ module Handler.Comment where import Import postCommentR :: Handler Value -postCommentR = do +postCommentR -- 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). + = do 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 } - + let comment' = comment {commentUserId = maybeCurrentUserId} insertedComment <- runDB $ insertEntity comment' returnJson insertedComment diff --git a/src/Handler/Common.hs b/src/Handler/Common.hs index 6783f8a..d418260 100644 --- a/src/Handler/Common.hs +++ b/src/Handler/Common.hs @@ -3,6 +3,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} + -- | Common handler functions. module Handler.Common where @@ -11,12 +12,10 @@ import Import -- These handlers embed files in the executable at compile time to avoid a -- runtime dependency, and for efficiency. - getFaviconR :: Handler TypedContent -getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month - 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 - $ toContent $(embedFile "config/robots.txt") +getRobotsR = return $ TypedContent typePlain $ toContent $(embedFile "config/robots.txt") diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 11dec1c..02d13a0 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -3,11 +3,13 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} + module Handler.Home where import Import -import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3) -import Text.Julius (RawJS (..)) +import Text.Julius (RawJS(..)) +import Yesod.Form.Bootstrap3 + (BootstrapFormLayout(..), renderBootstrap3) -- Define our data that will be used for creating the form. data FileForm = FileForm @@ -37,10 +39,10 @@ postHomeR :: Handler Html postHomeR = do ((result, formWidget), formEnctype) <- runFormPost sampleForm let handlerName = "postHomeR" :: Text - submission = case result of - FormSuccess res -> Just res - _ -> Nothing - + submission = + case result of + FormSuccess res -> Just res + _ -> Nothing defaultLayout $ do let (commentFormId, commentTextareaId, commentListId) = commentIds aDomId <- newIdent @@ -48,20 +50,10 @@ postHomeR = do $(widgetFile "homepage") sampleForm :: Form FileForm -sampleForm = renderBootstrap3 BootstrapBasicForm $ FileForm - <$> fileAFormReq "Choose a file" - <*> areq textField textSettings Nothing +sampleForm = renderBootstrap3 BootstrapBasicForm $ FileForm <$> fileAFormReq "Choose a file" <*> areq textField textSettings Nothing -- Add attributes like the placeholder and CSS classes. - where textSettings = FieldSettings - { fsLabel = "What's on the file?" - , fsTooltip = Nothing - , fsId = Nothing - , fsName = Nothing - , fsAttrs = - [ ("class", "form-control") - , ("placeholder", "File description") - ] - } + where + textSettings = FieldSettings {fsLabel = "What's on the file?", fsTooltip = Nothing, fsId = Nothing, fsName = Nothing, fsAttrs = [("class", "form-control"), ("placeholder", "File description")]} commentIds :: (Text, Text, Text) commentIds = ("js-commentForm", "js-createCommentTextarea", "js-commentList") diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index f0b8102..08ef946 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -3,6 +3,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} + module Handler.Profile where import Import diff --git a/src/Import.hs b/src/Import.hs index a102001..ffa10ae 100644 --- a/src/Import.hs +++ b/src/Import.hs @@ -2,5 +2,5 @@ module Import ( module Import ) where -import Foundation as Import -import Import.NoFoundation as Import +import Foundation as Import +import Import.NoFoundation as Import diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 9ca93f2..3e86ebc 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -1,12 +1,13 @@ {-# LANGUAGE CPP #-} + module Import.NoFoundation ( module Import ) where -import ClassyPrelude.Yesod as Import -import Model as Import -import Settings as Import -import Settings.StaticFiles as Import -import Yesod.Auth as Import -import Yesod.Core.Types as Import (loggerSet) +import ClassyPrelude.Yesod as Import +import Model as Import +import Settings as Import +import Settings.StaticFiles as Import +import Yesod.Auth as Import +import Yesod.Core.Types as Import (loggerSet) import Yesod.Default.Config2 as Import diff --git a/src/Model.hs b/src/Model.hs index 4420c16..d71b100 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + module Model where import ClassyPrelude.Yesod @@ -16,5 +17,4 @@ import Database.Persist.Quasi -- 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") +share [mkPersist sqlSettings, mkMigrate "migrateAll"] $(persistFileWith lowerCaseSettings "config/models") diff --git a/src/Settings/StaticFiles.hs b/src/Settings/StaticFiles.hs index 0cefeaa..cbf5233 100644 --- a/src/Settings/StaticFiles.hs +++ b/src/Settings/StaticFiles.hs @@ -1,9 +1,10 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} + module Settings.StaticFiles where -import Settings (appStaticDir, compileTimeAppSettings) +import Settings (appStaticDir, compileTimeAppSettings) import Yesod.Static (staticFiles) -- This generates easy references to files in the static directory at compile time, diff --git a/test/Handler/CommentSpec.hs b/test/Handler/CommentSpec.hs index 0b5225c..e48fc5d 100644 --- a/test/Handler/CommentSpec.hs +++ b/test/Handler/CommentSpec.hs @@ -1,43 +1,38 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -module Handler.CommentSpec (spec) where -import TestImport +module Handler.CommentSpec + ( spec + ) where + import Data.Aeson +import TestImport 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 - +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/Handler/CommonSpec.hs b/test/Handler/CommonSpec.hs index e1920fb..64b587c 100644 --- a/test/Handler/CommonSpec.hs +++ b/test/Handler/CommonSpec.hs @@ -1,17 +1,20 @@ -module Handler.CommonSpec (spec) where +module Handler.CommonSpec + ( spec + ) where import TestImport spec :: Spec -spec = withApp $ do - describe "robots.txt" $ do - it "gives a 200" $ do - get RobotsR - statusIs 200 - it "has correct User-agent" $ do - get RobotsR - bodyContains "User-agent: *" - describe "favicon.ico" $ do - it "gives a 200" $ do - get FaviconR - statusIs 200 +spec = + withApp $ do + describe "robots.txt" $ do + it "gives a 200" $ do + get RobotsR + statusIs 200 + it "has correct User-agent" $ do + get RobotsR + bodyContains "User-agent: *" + describe "favicon.ico" $ do + it "gives a 200" $ do + get FaviconR + statusIs 200 diff --git a/test/Handler/HomeSpec.hs b/test/Handler/HomeSpec.hs index 5ad3222..787bd11 100644 --- a/test/Handler/HomeSpec.hs +++ b/test/Handler/HomeSpec.hs @@ -1,35 +1,35 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -module Handler.HomeSpec (spec) where + +module Handler.HomeSpec + ( spec + ) where import TestImport spec :: Spec -spec = withApp $ do - - describe "Homepage" $ do - it "loads the index and checks it looks right" $ do - get HomeR - statusIs 200 - htmlAnyContain "h1" "a modern framework for blazing fast websites" - - request $ do - setMethod "POST" - setUrl HomeR - addToken - fileByLabel "Choose a file" "test/Spec.hs" "text/plain" -- talk about self-reference - byLabel "What's on the file?" "Some Content" - - statusIs 200 +spec = + withApp $ do + describe "Homepage" $ do + it "loads the index and checks it looks right" $ do + get HomeR + statusIs 200 + htmlAnyContain "h1" "a modern framework for blazing fast websites" + request $ do + setMethod "POST" + setUrl HomeR + addToken + fileByLabel "Choose a file" "test/Spec.hs" "text/plain" -- talk about self-reference + byLabel "What's on the file?" "Some Content" + statusIs 200 -- more debugging printBody - htmlAllContain ".upload-response" "text/plain" - htmlAllContain ".upload-response" "Some Content" - + htmlAllContain ".upload-response" "text/plain" + htmlAllContain ".upload-response" "Some Content" -- This is a simple example of using a database access in a test. The -- test will succeed for a fresh scaffolded site with an empty database, -- but will fail on an existing database with a non-empty user table. - it "leaves the user table empty" $ do - get HomeR - statusIs 200 - users <- runDB $ selectList ([] :: [Filter User]) [] - assertEq "user table empty" 0 $ length users + it "leaves the user table empty" $ do + get HomeR + statusIs 200 + users <- runDB $ selectList ([] :: [Filter User]) [] + assertEq "user table empty" 0 $ length users diff --git a/test/Handler/ProfileSpec.hs b/test/Handler/ProfileSpec.hs index 1f96f7f..99751da 100644 --- a/test/Handler/ProfileSpec.hs +++ b/test/Handler/ProfileSpec.hs @@ -1,28 +1,27 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -module Handler.ProfileSpec (spec) where + +module Handler.ProfileSpec + ( spec + ) where import TestImport spec :: Spec -spec = withApp $ do - - describe "Profile page" $ do - it "asserts no access to my-account for anonymous users" $ do - get ProfileR - statusIs 403 - - it "asserts access to my-account for authenticated users" $ do - userEntity <- createUser "foo" - authenticateAs userEntity - - get ProfileR - statusIs 200 - - it "asserts user's information is shown" $ do - userEntity <- createUser "bar" - authenticateAs userEntity - - get ProfileR - let (Entity _ user) = userEntity - htmlAnyContain ".username" . unpack $ userIdent user +spec = + withApp $ do + describe "Profile page" $ do + it "asserts no access to my-account for anonymous users" $ do + get ProfileR + statusIs 403 + it "asserts access to my-account for authenticated users" $ do + userEntity <- createUser "foo" + authenticateAs userEntity + get ProfileR + statusIs 200 + it "asserts user's information is shown" $ do + userEntity <- createUser "bar" + authenticateAs userEntity + get ProfileR + let (Entity _ user) = userEntity + htmlAnyContain ".username" . unpack $ userIdent user diff --git a/test/TestImport.hs b/test/TestImport.hs index e4f9cd0..6151866 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -1,23 +1,26 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} + module TestImport ( module TestImport , module X ) where -import Application (makeFoundation, makeLogWare) -import ClassyPrelude as X hiding (delete, deleteBy, Handler) -import Database.Persist as X hiding (get) -import Database.Persist.Sql (SqlPersistM, SqlBackend, runSqlPersistMPool, rawExecute, rawSql, unSingle, connEscapeName) -import Foundation as X -import Model as X -import Test.Hspec as X +import Application (makeFoundation, makeLogWare) +import ClassyPrelude as X hiding (Handler, delete, deleteBy) +import Database.Persist as X hiding (get) +import Database.Persist.Sql + (SqlBackend, SqlPersistM, connEscapeName, rawExecute, rawSql, + runSqlPersistMPool, unSingle) +import Foundation as X +import Model as X +import Test.Hspec as X import Text.Shakespeare.Text (st) -import Yesod.Default.Config2 (useEnv, loadYamlSettings) -import Yesod.Auth as X -import Yesod.Test as X -import Yesod.Core.Unsafe (fakeHandlerGetLogger) +import Yesod.Auth as X +import Yesod.Core.Unsafe (fakeHandlerGetLogger) +import Yesod.Default.Config2 (loadYamlSettings, useEnv) +import Yesod.Test as X runDB :: SqlPersistM a -> YesodExample App a runDB query = do @@ -32,38 +35,37 @@ runHandler handler = do app <- getTestYesod fakeHandlerGetLogger appLogger app handler - withApp :: SpecWith (TestApp App) -> Spec -withApp = before $ do - settings <- loadYamlSettings - ["config/test-settings.yml", "config/settings.yml"] - [] - useEnv - foundation <- makeFoundation settings - wipeDB foundation - logWare <- liftIO $ makeLogWare foundation - return (foundation, logWare) +withApp = + before $ do + settings <- loadYamlSettings ["config/test-settings.yml", "config/settings.yml"] [] useEnv + foundation <- makeFoundation settings + wipeDB foundation + logWare <- liftIO $ makeLogWare foundation + return (foundation, logWare) -- 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 app = runDBWithApp app $ do - tables <- getTables - sqlBackend <- ask - - let escapedTables = map (connEscapeName sqlBackend . DBName) tables - query = "TRUNCATE TABLE " ++ intercalate ", " escapedTables - rawExecute query [] +wipeDB app = + runDBWithApp app $ do + tables <- getTables + sqlBackend <- ask + let escapedTables = map (connEscapeName sqlBackend . DBName) tables + query = "TRUNCATE TABLE " ++ intercalate ", " escapedTables + rawExecute query [] getTables :: MonadIO m => ReaderT SqlBackend m [Text] getTables = do - tables <- rawSql [st| + tables <- + rawSql + [st| SELECT table_name FROM information_schema.tables WHERE table_schema = 'public'; - |] [] - + |] + [] return $ map unSingle tables -- | Authenticate as a user. This relies on the `auth-dummy-login: true` flag @@ -79,7 +81,4 @@ authenticateAs (Entity _ u) = do -- | Create a user. createUser :: Text -> YesodExample App (Entity User) createUser ident = do - runDB $ insertEntity User - { userIdent = ident - , userPassword = Nothing - } + runDB $ insertEntity User {userIdent = ident, userPassword = Nothing} From 818f5316d67490fd2a5c4fd310165b09623cc195 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 12 Jun 2017 08:57:59 +0300 Subject: [PATCH 2/2] Change line length to 80 on script as-well --- hindent_all | 6 +++-- src/Application.hs | 18 ++++++++++--- src/Foundation.hs | 53 ++++++++++++++++++++++++++++++------- src/Handler/Common.hs | 7 +++-- src/Handler/Home.hs | 15 +++++++++-- src/Model.hs | 4 ++- test/Handler/CommentSpec.hs | 3 ++- test/Handler/HomeSpec.hs | 4 ++- test/TestImport.hs | 6 ++++- 9 files changed, 94 insertions(+), 22 deletions(-) diff --git a/hindent_all b/hindent_all index f3a0992..dae75d4 100755 --- a/hindent_all +++ b/hindent_all @@ -1,11 +1,13 @@ #!/usr/bin/env bash +# Based on https://github.com/commercialhaskell/hindent/issues/309#issue-180517159 + set -e HINDENT=hindent GIT=git -LINE_LENGTH=200 +LINE_LENGTH=80 function hindent_file { filename="$1" @@ -19,7 +21,7 @@ function list_haskell_files { # TODO: Figure out if it's a Haskell file in a more reliable way, e.g. # using `file`, or just running hindent on everything. - # TODO: Exclude ./src/Settings.hs + # TODO: Exclude ./src/Settings.hs, due to https://github.com/commercialhaskell/hindent/issues/383 ${GIT} ls-files './*.hs' } diff --git a/src/Application.hs b/src/Application.hs index 18ed1a6..e515499 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -73,10 +73,15 @@ makeFoundation appSettings -- The App {..} 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" + tempFoundation = + mkFoundation $ error "connPool forced in tempFoundation" logFunc = messageLoggerSource tempFoundation appLogger -- Create the database connection pool - pool <- flip runLoggingT logFunc $ createPostgresqlPool (pgConnStr $ appDatabaseConf appSettings) (pgPoolSize $ appDatabaseConf appSettings) + pool <- + flip runLoggingT logFunc $ + createPostgresqlPool + (pgConnStr $ appDatabaseConf appSettings) + (pgPoolSize $ appDatabaseConf appSettings) -- Perform database migration using our application's logging settings. runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc -- Return the foundation @@ -112,7 +117,14 @@ warpSettings foundation = setHost (appHost $ appSettings foundation) $ setOnException (\_req e -> - when (defaultShouldDisplayException e) $ messageLoggerSource foundation (appLogger foundation) $(qLocation >>= liftLoc) "yesod" LevelError (toLogStr $ "Exception from Warp: " ++ show e)) + when (defaultShouldDisplayException e) $ + messageLoggerSource + foundation + (appLogger foundation) + $(qLocation >>= liftLoc) + "yesod" + LevelError + (toLogStr $ "Exception from Warp: " ++ show e)) defaultSettings -- | For yesod devel, return the Warp settings and WAI Application. diff --git a/src/Foundation.hs b/src/Foundation.hs index 8f668e7..de5f72b 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -95,15 +95,37 @@ instance Yesod App (title, parents) <- breadcrumbs -- Define the menu items of the header. let menuItems = - [ NavbarLeft $ MenuItem {menuItemLabel = "Home", menuItemRoute = HomeR, menuItemAccessCallback = True} - , NavbarLeft $ MenuItem {menuItemLabel = "Profile", menuItemRoute = ProfileR, menuItemAccessCallback = isJust muser} - , NavbarRight $ MenuItem {menuItemLabel = "Login", menuItemRoute = AuthR LoginR, menuItemAccessCallback = isNothing muser} - , NavbarRight $ MenuItem {menuItemLabel = "Logout", menuItemRoute = AuthR LogoutR, menuItemAccessCallback = isJust muser} + [ NavbarLeft $ + MenuItem + { menuItemLabel = "Home" + , menuItemRoute = HomeR + , menuItemAccessCallback = True + } + , NavbarLeft $ + MenuItem + { menuItemLabel = "Profile" + , menuItemRoute = ProfileR + , menuItemAccessCallback = isJust muser + } + , NavbarRight $ + MenuItem + { menuItemLabel = "Login" + , menuItemRoute = AuthR LoginR + , menuItemAccessCallback = isNothing muser + } + , NavbarRight $ + MenuItem + { menuItemLabel = "Logout" + , menuItemRoute = AuthR LogoutR + , menuItemAccessCallback = isJust muser + } ] let navbarLeftMenuItems = [x | NavbarLeft x <- menuItems] let navbarRightMenuItems = [x | NavbarRight x <- menuItems] - let navbarLeftFilteredMenuItems = [x | x <- navbarLeftMenuItems, menuItemAccessCallback x] - let navbarRightFilteredMenuItems = [x | x <- navbarRightMenuItems, menuItemAccessCallback x] + let navbarLeftFilteredMenuItems = + [x | x <- navbarLeftMenuItems, menuItemAccessCallback x] + let navbarRightFilteredMenuItems = + [x | x <- navbarRightMenuItems, menuItemAccessCallback x] -- We break up the default layout into two components: -- default-layout is the contents of the body tag, and -- default-layout-wrapper is the entire page. Since the final @@ -131,13 +153,22 @@ instance Yesod App addStaticContent ext mime content = do master <- getYesod let staticDir = appStaticDir $ appSettings master - addStaticContentExternal minifym genFileName staticDir (StaticR . flip StaticRoute []) ext mime content + addStaticContentExternal + minifym + genFileName + staticDir + (StaticR . flip StaticRoute []) + ext + mime + content -- Generate a unique filename based on the content itself where genFileName lbs = "autogen-" ++ base64md5 lbs -- What messages should be logged. The following includes all messages when -- in development, and warnings and errors in production. - shouldLog app _source level = appShouldLogAll (appSettings app) || level == LevelWarn || level == LevelError + shouldLog app _source level = + appShouldLogAll (appSettings app) || + level == LevelWarn || level == LevelError makeLogger = return . appLogger -- Define breadcrumbs. @@ -170,7 +201,11 @@ instance YesodAuth App where x <- getBy $ UniqueUser $ credsIdent creds case x of Just (Entity uid _) -> return $ Authenticated uid - Nothing -> Authenticated <$> insert User {userIdent = credsIdent creds, userPassword = Nothing} + Nothing -> + Authenticated <$> + insert + User + {userIdent = credsIdent creds, userPassword = Nothing} -- You can add other plugins like Google Email, email or OAuth here authPlugins app = [authOpenId Claimed []] ++ extraAuthPlugins -- Enable authDummy login if enabled. diff --git a/src/Handler/Common.hs b/src/Handler/Common.hs index d418260..ba2e876 100644 --- a/src/Handler/Common.hs +++ b/src/Handler/Common.hs @@ -15,7 +15,10 @@ 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") + return $ + TypedContent "image/x-icon" $ + toContent $(embedFile "config/favicon.ico") getRobotsR :: Handler TypedContent -getRobotsR = return $ TypedContent typePlain $ toContent $(embedFile "config/robots.txt") +getRobotsR = + return $ TypedContent typePlain $ toContent $(embedFile "config/robots.txt") diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 02d13a0..0ca2440 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -50,10 +50,21 @@ postHomeR = do $(widgetFile "homepage") sampleForm :: Form FileForm -sampleForm = renderBootstrap3 BootstrapBasicForm $ FileForm <$> fileAFormReq "Choose a file" <*> areq textField textSettings Nothing +sampleForm = + renderBootstrap3 BootstrapBasicForm $ + FileForm <$> fileAFormReq "Choose a file" <*> + areq textField textSettings Nothing -- Add attributes like the placeholder and CSS classes. where - textSettings = FieldSettings {fsLabel = "What's on the file?", fsTooltip = Nothing, fsId = Nothing, fsName = Nothing, fsAttrs = [("class", "form-control"), ("placeholder", "File description")]} + textSettings = + FieldSettings + { fsLabel = "What's on the file?" + , fsTooltip = Nothing + , fsId = Nothing + , fsName = Nothing + , fsAttrs = + [("class", "form-control"), ("placeholder", "File description")] + } commentIds :: (Text, Text, Text) commentIds = ("js-commentForm", "js-createCommentTextarea", "js-commentList") diff --git a/src/Model.hs b/src/Model.hs index d71b100..2dac0be 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -17,4 +17,6 @@ import Database.Persist.Quasi -- 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") +share + [mkPersist sqlSettings, mkMigrate "migrateAll"] + $(persistFileWith lowerCaseSettings "config/models") diff --git a/test/Handler/CommentSpec.hs b/test/Handler/CommentSpec.hs index e48fc5d..58cf593 100644 --- a/test/Handler/CommentSpec.hs +++ b/test/Handler/CommentSpec.hs @@ -24,7 +24,8 @@ spec = setRequestBody encoded addRequestHeader ("Content-Type", "application/json") statusIs 200 - [Entity _id comment] <- runDB $ selectList [CommentMessage ==. message] [] + [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 diff --git a/test/Handler/HomeSpec.hs b/test/Handler/HomeSpec.hs index 787bd11..39fa506 100644 --- a/test/Handler/HomeSpec.hs +++ b/test/Handler/HomeSpec.hs @@ -14,7 +14,9 @@ spec = it "loads the index and checks it looks right" $ do get HomeR statusIs 200 - htmlAnyContain "h1" "a modern framework for blazing fast websites" + htmlAnyContain + "h1" + "a modern framework for blazing fast websites" request $ do setMethod "POST" setUrl HomeR diff --git a/test/TestImport.hs b/test/TestImport.hs index 6151866..5535d30 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -38,7 +38,11 @@ runHandler handler = do withApp :: SpecWith (TestApp App) -> Spec withApp = before $ do - settings <- loadYamlSettings ["config/test-settings.yml", "config/settings.yml"] [] useEnv + settings <- + loadYamlSettings + ["config/test-settings.yml", "config/settings.yml"] + [] + useEnv foundation <- makeFoundation settings wipeDB foundation logWare <- liftIO $ makeLogWare foundation