From d84b462a711ce95593ff05a7581e722562c3835a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 14 Mar 2017 01:06:28 +0100 Subject: Implement old bar.hs --- .dir-locals.el | 4 + .gitignore | 23 ++++ Application.hs | 180 ++++++++++++++++++++++++++++++++ Foundation.hs | 141 +++++++++++++++++++++++++ Handler/Common.hs | 78 ++++++++++++++ Handler/Common/Types.hs | 23 ++++ Handler/DeleteItem.hs | 10 ++ Handler/InventoryListing.hs | 26 +++++ Handler/Item.hs | 31 ++++++ Handler/OpenItem.hs | 12 +++ Handler/UpdateItem.hs | 33 ++++++ Import.hs | 6 ++ Import/NoFoundation.hs | 13 +++ Model.hs | 96 +++++++++++++++++ Settings.hs | 107 +++++++++++++++++++ Settings/StaticFiles.hs | 13 +++ all.gup | 3 + app/DevelMain.hs | 99 ++++++++++++++++++ app/devel.hs | 6 ++ app/main.hs | 5 + bar.cabal | 128 +++++++++++++++++++++++ bar.nix | 30 ++++++ bar.nix.gup | 5 + config/models | 12 +++ config/routes | 7 ++ config/settings.yml | 26 +++++ default.nix | 29 +++++ shell.nix | 18 ++++ stack.yaml | 73 +++++++++++++ static/jquery.js.gup | 3 + static/webshim.gup | 6 ++ templates/default-layout-wrapper.hamlet | 15 +++ templates/default-layout.cassius | 77 ++++++++++++++ templates/default-layout.hamlet | 12 +++ templates/default-layout.julius | 7 ++ templates/default-message-widget.hamlet | 6 ++ templates/homepage.hamlet | 139 ++++++++++++++++++++++++ templates/homepage.julius | 34 ++++++ templates/homepage.lucius | 13 +++ templates/inventoryListing.hamlet | 49 +++++++++ templates/profile.hamlet | 10 ++ 41 files changed, 1608 insertions(+) create mode 100644 .dir-locals.el create mode 100644 .gitignore create mode 100644 Application.hs create mode 100644 Foundation.hs create mode 100644 Handler/Common.hs create mode 100644 Handler/Common/Types.hs create mode 100644 Handler/DeleteItem.hs create mode 100644 Handler/InventoryListing.hs create mode 100644 Handler/Item.hs create mode 100644 Handler/OpenItem.hs create mode 100644 Handler/UpdateItem.hs create mode 100644 Import.hs create mode 100644 Import/NoFoundation.hs create mode 100644 Model.hs create mode 100644 Settings.hs create mode 100644 Settings/StaticFiles.hs create mode 100644 all.gup create mode 100644 app/DevelMain.hs create mode 100644 app/devel.hs create mode 100644 app/main.hs create mode 100644 bar.cabal create mode 100644 bar.nix create mode 100644 bar.nix.gup create mode 100644 config/models create mode 100644 config/routes create mode 100644 config/settings.yml create mode 100644 default.nix create mode 100644 shell.nix create mode 100644 stack.yaml create mode 100644 static/jquery.js.gup create mode 100644 static/webshim.gup create mode 100644 templates/default-layout-wrapper.hamlet create mode 100644 templates/default-layout.cassius create mode 100644 templates/default-layout.hamlet create mode 100644 templates/default-layout.julius create mode 100644 templates/default-message-widget.hamlet create mode 100644 templates/homepage.hamlet create mode 100644 templates/homepage.julius create mode 100644 templates/homepage.lucius create mode 100644 templates/inventoryListing.hamlet create mode 100644 templates/profile.hamlet diff --git a/.dir-locals.el b/.dir-locals.el new file mode 100644 index 0000000..a44395f --- /dev/null +++ b/.dir-locals.el @@ -0,0 +1,4 @@ +((haskell-mode . ((haskell-indent-spaces . 4) + (haskell-process-use-ghci . t))) + (hamlet-mode . ((hamlet/basic-offset . 4) + (haskell-process-use-ghci . t)))) diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..5747830 --- /dev/null +++ b/.gitignore @@ -0,0 +1,23 @@ +dist* +static/tmp/ +static/combined/ +config/client_session_key.aes +*.hi +*.o +*.sqlite3 +*.sqlite3-shm +*.sqlite3-wal +.hsenv* +cabal-dev/ +.stack-work/ +yesod-devel/ +.cabal-sandbox +cabal.sandbox.config +.DS_Store +*.swp +*.keter +**/result +**/client_session_key.aes +**/.gup +static/webshim/ +static/jquery.js diff --git a/Application.hs b/Application.hs new file mode 100644 index 0000000..048a316 --- /dev/null +++ b/Application.hs @@ -0,0 +1,180 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Application + ( getApplicationDev + , appMain + , develMain + , makeFoundation + , makeLogWare + -- * for DevelMain + , getApplicationRepl + , shutdownApp + -- * for GHCI + , handler + , db + ) where + +import Control.Monad.Logger (liftLoc, runLoggingT) +import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr, + pgPoolSize, runSqlPool) +import Import +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 all relevant handler modules here. +-- Don't forget to add new modules to your cabal file! +import Handler.InventoryListing +import Handler.UpdateItem +import Handler.OpenItem +import Handler.DeleteItem +import Handler.Item + +-- 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 + +-- | 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 = do + -- Some basic initializations: HTTP connection manager, logger, and static + -- subsite. + appHttpManager <- newManager + appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger + + -- 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 + -- temporary foundation without a real connection pool, get a log function + -- from there, and then create the real foundation. + let mkFoundation appConnPool = App { appStatic = eStatic, ..} + -- 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" + logFunc = messageLoggerSource tempFoundation appLogger + + -- Create the database connection pool + 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 + +-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and +-- applying some additional middlewares. +makeApplication :: App -> 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 foundation = + mkRequestLogger def + { outputFormat = + 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 + +-- | For yesod devel, return the Warp settings and WAI Application. +getApplicationDev :: IO (Settings, Application) +getApplicationDev = do + settings <- getAppSettings + foundation <- makeFoundation settings + wsettings <- getDevSettings $ warpSettings foundation + app <- makeApplication foundation + return (wsettings, app) + +getAppSettings :: IO AppSettings +getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv + +-- | main function for use by yesod devel +develMain :: IO () +develMain = develMainHelper getApplicationDev + +-- | The @main@ function for an executable running this site. +appMain :: IO () +appMain = do + -- Get the settings from all relevant sources + settings <- loadYamlSettingsArgs + -- fall back to compile-time values, set to [] to require values at runtime + [configSettingsYmlValue] + + -- allow environment variables to override + 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) +-------------------------------------------------------------- +getApplicationRepl :: IO (Int, App, Application) +getApplicationRepl = do + settings <- getAppSettings + foundation <- makeFoundation settings + wsettings <- getDevSettings $ warpSettings foundation + app1 <- makeApplication foundation + return (getPort wsettings, foundation, app1) + +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 + +-- | Run DB queries +db :: ReaderT SqlBackend (HandlerT App IO) a -> IO a +db = handler . runDB diff --git a/Foundation.hs b/Foundation.hs new file mode 100644 index 0000000..85512a3 --- /dev/null +++ b/Foundation.hs @@ -0,0 +1,141 @@ +module Foundation where + +import Import.NoFoundation +import Database.Persist.Sql (ConnectionPool, runSqlPool) +import Text.Hamlet (hamletFile) + +import Yesod.Core.Types (Logger) +import qualified Yesod.Core.Unsafe as Unsafe + +-- | 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 :: EmbeddedStatic + , appConnPool :: ConnectionPool -- ^ Database connection pool. + , appHttpManager :: Manager + , appLogger :: Logger + } + +data MenuItem = MenuItem + { menuItemLabel :: Text + , menuItemRoute :: Route App + } + +-- This is where we define all of the routes in our application. For a full +-- explanation of the syntax, please see: +-- http://www.yesodweb.com/book/routing-and-handlers +-- +-- Note that this is really half the story; in Application.hs, mkYesodDispatch +-- generates the rest of the code. Please see the following documentation +-- for an explanation for this split: +-- 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") + +-- | A convenient synonym for creating forms. +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 + -- 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 + + -- Store session data on the client in encrypted cookies, + -- default session idle timeout is 120 minutes + makeSessionBackend _ = Just <$> defaultClientSessionBackend + 120 -- timeout in minutes + "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: + -- a) Sets a cookie with a CSRF token in it. + -- b) Validates that incoming write requests include that token in either a header or POST parameter. + -- 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 + msgs <- getMessages + + mCurrentRoute <- getCurrentRoute + + -- Define the menu items of the header. + let menuItems = + [ MenuItem "Inventory" InventoryListingR + ] + + -- 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 + addScript $ StaticR jquery_js + addScript $ StaticR webshim_polyfiller_js + $(widgetFile "default-layout") + withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") + + + -- 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 + -- users receiving stale content. + addStaticContent = embedStaticContent appStatic StaticR Right + + -- 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 + + makeLogger = return . appLogger + + -- Provide proper Bootstrap styling for default displays, like + -- error pages + defaultMessageWidget title body = $(widgetFile "default-message-widget") + +-- 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 + getDBRunner = defaultGetDBRunner appConnPool + +-- This instance is required to use forms. You can modify renderMessage to +-- achieve customized and internationalized form validation messages. +instance RenderMessage App 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 + getHttpManager = appHttpManager + +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: +-- +-- https://github.com/yesodweb/yesod/wiki/Sending-email +-- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain +-- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding diff --git a/Handler/Common.hs b/Handler/Common.hs new file mode 100644 index 0000000..38fb1ce --- /dev/null +++ b/Handler/Common.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE ApplicativeDo #-} + +module Handler.Common + ( inventoryListing + , itemForm + , InventoryState(..) + , FormState(..) + ) where + +import Import + +import Data.Unique + +import qualified Data.Text as Text (pack) + +import Control.Lens + +import Handler.Common.Types + +dayFormat :: Day -> String +dayFormat = formatTime defaultTimeLocale "%e. %b %y" + +itemForm :: Maybe Item -- ^ Update existing item or insert new? + -> Html -> MForm Handler (FormResult Item, Widget) +itemForm proto identView = do + today <- utctDay <$> liftIO getCurrentTime + + (kindRes, kindView) <- mreq textField "" $ itemKind <$> proto + (boughtRes, boughtWidget) <- dayForm (maybe (Just $ Just today) Just $ fmap itemBought proto) "Unknown" + (expiresRes, expiresWidget) <- dayForm (fmap itemExpires proto) "Never" + (openedRes, openedWidget) <- dayForm (fmap itemOpened proto) "Never" + + let itemRes = do + itemKind <- kindRes + itemBought <- boughtRes + itemExpires <- expiresRes + itemOpened <- openedRes + return Item{ itemNormKind = normalizeKind itemKind, ..} + + return . (itemRes, ) $ + [whamlet| + $newline never + #{identView} +
^{fvInput kindView} +
^{boughtWidget} +
^{expiresWidget} +
^{openedWidget} + |] + where + dayForm :: Maybe (Maybe Day) -> String -> MForm Handler (FormResult (Maybe Day), Widget) + dayForm proto label = do + today <- utctDay <$> liftIO getCurrentTime + + checkboxId <- ("check" <>) . show . hashUnique <$> liftIO newUnique + + (fmap (fromMaybe False) -> isNothingRes, isNothingView) <- + mopt checkBoxField ("" { fsId = Just $ Text.pack checkboxId }) . Just . Just . fromMaybe True $ fmap isNothing proto + (dayRes, dayView) <- + mreq dayField "" . Just . fromMaybe today $ join proto + + let res = (bool Just (const Nothing) <$> isNothingRes) <*> dayRes + return . (res, ) $ do + [whamlet| + $newline never +
+
+