From d84b462a711ce95593ff05a7581e722562c3835a Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
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}
+ <div .td>^{fvInput kindView}
+ <div .td>^{boughtWidget}
+ <div .td>^{expiresWidget}
+ <div .td>^{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
+ <div .table>
+ <div .tr>
+ <label for=#{checkboxId} .checkbox .td>
+ ^{fvInput isNothingView}
+ <span>
+ #{label}
+ <div .tr>
+ <div .td .dayInput>^{fvInput dayView}
+ |]
+
+inventoryListing :: InventoryState -> Widget
+inventoryListing InventoryState{..} = do
+ setTitle "Bar Inventory"
+ $(widgetFile "inventoryListing")
diff --git a/Handler/Common/Types.hs b/Handler/Common/Types.hs
new file mode 100644
index 0000000..ca7cb8d
--- /dev/null
+++ b/Handler/Common/Types.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE FunctionalDependencies #-}
+
+module Handler.Common.Types where
+
+import Import
+
+import Control.Lens
+
+data InventoryState = InventoryState
+ { stock :: [Entity Item]
+ , formState :: Maybe FormState
+ }
+
+data FormState = InsertForm
+ { fsInsertForm :: Widget
+ , fsInsertEncoding :: Enctype
+ }
+ | UpdateForm
+ { fsUpdateItem :: ItemId
+ , fsUpdateForm :: Widget
+ , fsUpdateEncoding :: Enctype
+ }
+makeLensesWith abbreviatedFields ''FormState
diff --git a/Handler/DeleteItem.hs b/Handler/DeleteItem.hs
new file mode 100644
index 0000000..ee6d9d3
--- /dev/null
+++ b/Handler/DeleteItem.hs
@@ -0,0 +1,10 @@
+module Handler.DeleteItem where
+
+import Import
+
+postDeleteItemR :: ItemId -> Handler TypedContent
+postDeleteItemR itemId = do
+ runDB $ delete itemId
+ selectRep $ do
+ provideJson ()
+ provideRep (redirect $ InventoryListingR :: Handler Html)
diff --git a/Handler/InventoryListing.hs b/Handler/InventoryListing.hs
new file mode 100644
index 0000000..e3c062e
--- /dev/null
+++ b/Handler/InventoryListing.hs
@@ -0,0 +1,26 @@
+module Handler.InventoryListing where
+
+import Import
+import Handler.Common
+
+getInventoryListingR, postInventoryListingR :: Handler TypedContent
+getInventoryListingR = postInventoryListingR
+postInventoryListingR = do
+ ((insertResult, fsInsertForm), fsInsertEncoding) <- runFormPost $ itemForm Nothing
+
+ mapM_ (addMessage "formError" . toHtml) =<< case insertResult of
+ FormSuccess newItem -> [] <$ runDB (insert newItem)
+ FormFailure errors -> return errors
+ _ -> return []
+
+ (sortOn entityVal -> stock) <- runDB $ selectList [] []
+
+ selectRep $ do
+ provideJson (stock :: [Entity Item])
+ provideRep . defaultLayout $ inventoryListing InventoryState
+ { formState = Just InsertForm{..}
+ , ..
+ }
+
+putInventoryListingR :: Handler Value
+putInventoryListingR = returnJson =<< runDB . insertEntity =<< (requireCheckJsonBody :: Handler Item)
diff --git a/Handler/Item.hs b/Handler/Item.hs
new file mode 100644
index 0000000..87030bb
--- /dev/null
+++ b/Handler/Item.hs
@@ -0,0 +1,31 @@
+module Handler.Item where
+
+import Import
+
+getItemR :: ItemId -> Handler TypedContent
+getItemR itemId = do
+ eLookup <- runDB $ fmap (Entity itemId) <$> get itemId
+ case eLookup of
+ Nothing -> notFound
+ Just entity -> selectRep $ do
+ provideJson entity
+ provideRep (redirect $ InventoryListingR :#: itemId :: Handler Html)
+
+putItemR :: ItemId -> Handler Value
+putItemR itemId = do
+ Item{..} <- requireCheckJsonBody
+ returnJson . Entity itemId =<< runDB
+ (updateGet itemId [ ItemKind =. itemKind
+ , ItemNormKind =. itemNormKind
+ , ItemBought =. itemBought
+ , ItemExpires =. itemExpires
+ , ItemOpened =. itemOpened
+ ])
+
+patchItemR :: ItemId -> Handler Value
+patchItemR itemId = do
+ diffs <- (requireCheckJsonBody :: Handler ItemDiffs)
+ returnJson . Entity itemId =<< runDB (updateGet itemId $ toUpdate diffs)
+
+deleteItemR :: ItemId -> Handler ()
+deleteItemR = runDB . delete
diff --git a/Handler/OpenItem.hs b/Handler/OpenItem.hs
new file mode 100644
index 0000000..468c6ec
--- /dev/null
+++ b/Handler/OpenItem.hs
@@ -0,0 +1,12 @@
+module Handler.OpenItem where
+
+import Import
+
+postOpenItemR :: ItemId -> Handler TypedContent
+postOpenItemR itemId = do
+ today <- utctDay <$> liftIO getCurrentTime
+ result <- fmap (Entity itemId) . runDB $ updateGet itemId [ ItemOpened =. Just today
+ ]
+ selectRep $ do
+ provideJson result
+ provideRep (redirect $ InventoryListingR :#: itemId :: Handler Html)
diff --git a/Handler/UpdateItem.hs b/Handler/UpdateItem.hs
new file mode 100644
index 0000000..353572b
--- /dev/null
+++ b/Handler/UpdateItem.hs
@@ -0,0 +1,33 @@
+module Handler.UpdateItem where
+
+import Import
+
+import Handler.Common
+
+getUpdateItemR, postUpdateItemR :: ItemId -> Handler TypedContent
+getUpdateItemR = postUpdateItemR
+postUpdateItemR fsUpdateItem = do
+ Just entity <- fmap (Entity fsUpdateItem) <$> runDB (get fsUpdateItem)
+
+ ((updateResult, fsUpdateForm), fsUpdateEncoding) <- runFormPost . itemForm . Just $ entityVal entity
+
+ mapM_ (addMessage "formError" . toHtml) =<< case updateResult of
+ FormSuccess Item{..} -> [] <$ runDB (update fsUpdateItem [ ItemKind =. itemKind
+ , ItemNormKind =. normalizeKind itemKind
+ , ItemBought =. itemBought
+ , ItemExpires =. itemExpires
+ , ItemOpened =. itemOpened
+ ])
+ FormFailure errors -> return errors
+ _ -> return []
+
+ selectRep $ do
+ provideRep $ case updateResult of
+ FormSuccess _ -> redirect $ InventoryListingR :#: fsUpdateItem :: Handler Html
+ _ -> do
+ (sortOn entityVal -> stock) <- runDB $ selectList [] []
+ defaultLayout $ inventoryListing InventoryState
+ { formState = Just UpdateForm{..}
+ , ..
+ }
+ provideJson ()
diff --git a/Import.hs b/Import.hs
new file mode 100644
index 0000000..a102001
--- /dev/null
+++ b/Import.hs
@@ -0,0 +1,6 @@
+module Import
+ ( module Import
+ ) where
+
+import Foundation as Import
+import Import.NoFoundation as Import
diff --git a/Import/NoFoundation.hs b/Import/NoFoundation.hs
new file mode 100644
index 0000000..6872d0a
--- /dev/null
+++ b/Import/NoFoundation.hs
@@ -0,0 +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 Yesod.Default.Config2 as Import
+import Yesod.EmbeddedStatic as Import
diff --git a/Model.hs b/Model.hs
new file mode 100644
index 0000000..7b33f6e
--- /dev/null
+++ b/Model.hs
@@ -0,0 +1,96 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module Model where
+
+import ClassyPrelude.Yesod
+import Database.Persist.Quasi
+
+import Control.Monad.Writer
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+
+import Data.Aeson
+
+-- 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")
+
+instance Ord Item where
+ x `compare` y = mconcat
+ [ (isNothing $ itemOpened x) `compare` (isNothing $ itemOpened y)
+ , itemOpened x `compare` itemOpened y
+ , (isNothing $ itemExpires x) `compare` (isNothing $ itemExpires y)
+ , itemExpires x `compare` itemExpires x
+ , itemKind x `compare` itemKind x
+ , itemBought x `compare` itemBought x
+ ]
+
+instance ToJSON Item where
+ toJSON Item{..} = object $
+ [ "kind" .= itemKind
+ ] ++ maybe [] (\x -> ["bought" .= x]) itemBought
+ ++ maybe [] (\x -> ["expires" .= x]) itemExpires
+ ++ maybe [] (\x -> ["opened" .= x]) itemOpened
+
+instance FromJSON Item where
+ parseJSON = withObject "Item" $ \obj -> do
+ itemKind <- obj .: "kind"
+ let
+ itemNormKind = normalizeKind itemKind
+ itemBought <- obj .:? "bought"
+ itemExpires <- obj .:? "expires"
+ itemOpened <- obj .:? "opened"
+ return Item{..}
+
+instance ToJSON (Entity Item) where
+ toJSON = entityIdToJSON
+
+instance FromJSON (Entity Item) where
+ parseJSON = entityIdFromJSON
+
+instance ToJSON Reference where
+ toJSON Reference{..} = String referenceKind
+
+instance FromJSON Reference where
+ parseJSON = withText "Reference" $ \referenceKind -> do
+ let
+ referenceNormKind = normalizeKind referenceKind
+ return Reference{..}
+
+instance ToJSON (Entity Reference) where
+ toJSON = keyValueEntityToJSON
+
+instance FromJSON (Entity Reference) where
+ parseJSON = keyValueEntityFromJSON
+
+normalizeKind :: Text -> Text
+normalizeKind = Text.strip . Text.toCaseFold
+
+data ItemDiff = DiffKind Text
+ | DiffBought (Maybe Day)
+ | DiffExpires (Maybe Day)
+ | DiffOpened (Maybe Day)
+
+newtype ItemDiffs = ItemDiffs [ItemDiff]
+
+instance FromJSON ItemDiffs where
+ parseJSON = withObject "ItemDiff" $ \obj -> fmap ItemDiffs . execWriterT $ do
+ tell =<< maybe [] (pure . DiffKind) <$> lift (obj .:? "kind")
+ tell =<< maybe [] (pure . DiffBought) <$> lift (obj .:! "bought")
+ tell =<< maybe [] (pure . DiffExpires) <$> lift (obj .:! "expires")
+ tell =<< maybe [] (pure . DiffOpened) <$> lift (obj .:! "opened")
+
+toUpdate :: ItemDiffs -> [Update Item]
+toUpdate (ItemDiffs ds) = do
+ x <- ds
+ case x of
+ DiffKind t -> [ ItemKind =. t
+ , ItemNormKind =. normalizeKind t
+ ]
+ DiffBought d -> [ ItemBought =. d ]
+ DiffExpires d -> [ ItemExpires =. d ]
+ DiffOpened d -> [ ItemOpened =. d ]
diff --git a/Settings.hs b/Settings.hs
new file mode 100644
index 0000000..76aa2f3
--- /dev/null
+++ b/Settings.hs
@@ -0,0 +1,107 @@
+{-# Language CPP #-}
+-- | Settings are centralized, as much as possible, into this file. This
+-- includes database connection settings, static file locations, etc.
+-- In addition, you can configure a number of different aspects of Yesod
+-- by overriding methods in the Yesod typeclass. That instance is
+-- declared in the Foundation.hs file.
+module Settings where
+
+import ClassyPrelude.Yesod
+import qualified Control.Exception as Exception
+import Data.Aeson (Result (..), fromJSON, withObject, (.!=),
+ (.:?))
+import Data.FileEmbed (embedFile)
+import Data.Yaml (decodeEither')
+import Database.Persist.Postgresql (PostgresConf)
+import Language.Haskell.TH.Syntax (Exp, Q)
+import Network.Wai.Handler.Warp (HostPreference)
+import Yesod.Default.Config2 (applyEnvValue, configSettingsYml)
+import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload,
+ widgetFileReload)
+
+#ifdef DEVELOPMENT
+#define DEV_BOOL True
+#else
+#define DEV_BOOL False
+#endif
+
+-- | Runtime settings to configure this application. These settings can be
+-- loaded from various sources: defaults, environment variables, config files,
+-- theoretically even a database.
+data AppSettings = AppSettings
+ { appStaticDir :: String
+ -- ^ Directory from which to serve static files.
+ , appDatabaseConf :: PostgresConf
+ -- ^ Configuration settings for accessing the database.
+ , appRoot :: Maybe Text
+ -- ^ Base for all generated URLs. If @Nothing@, determined
+ -- from the request headers.
+ , appHost :: HostPreference
+ -- ^ Host/interface the server should bind to.
+ , appPort :: Int
+ -- ^ Port to listen on
+ , appIpFromHeader :: Bool
+ -- ^ Get the IP address from the header when logging. Useful when sitting
+ -- behind a reverse proxy.
+
+ , appDetailedRequestLogging :: Bool
+ -- ^ Use detailed request logging system
+ , appShouldLogAll :: Bool
+ -- ^ Should all log messages be displayed?
+ , appReloadTemplates :: Bool
+ -- ^ Use the reload version of templates
+ }
+
+instance FromJSON AppSettings where
+ parseJSON = withObject "AppSettings" $ \o -> do
+ let defaultDev = DEV_BOOL
+ appStaticDir <- o .: "static-dir"
+ appDatabaseConf <- o .: "database"
+ appRoot <- o .:? "approot"
+ appHost <- fromString <$> o .: "host"
+ appPort <- o .: "port"
+ appIpFromHeader <- o .: "ip-from-header"
+
+ appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
+ appShouldLogAll <- o .:? "should-log-all" .!= defaultDev
+ appReloadTemplates <- o .:? "reload-templates" .!= defaultDev
+
+ return AppSettings {..}
+
+-- | Settings for 'widgetFile', such as which template languages to support and
+-- default Hamlet settings.
+--
+-- For more information on modifying behavior, see:
+--
+-- https://github.com/yesodweb/yesod/wiki/Overriding-widgetFile
+widgetFileSettings :: WidgetFileSettings
+widgetFileSettings = def
+
+-- | How static files should be combined.
+combineSettings :: CombineSettings
+combineSettings = def
+
+-- The rest of this file contains settings which rarely need changing by a
+-- user.
+
+widgetFile :: String -> Q Exp
+widgetFile = (if appReloadTemplates compileTimeAppSettings
+ then widgetFileReload
+ else widgetFileNoReload)
+ widgetFileSettings
+
+-- | Raw bytes at compile time of @config/settings.yml@
+configSettingsYmlBS :: ByteString
+configSettingsYmlBS = $(embedFile configSettingsYml)
+
+-- | @config/settings.yml@, parsed to a @Value@.
+configSettingsYmlValue :: Value
+configSettingsYmlValue = either Exception.throw id
+ $ decodeEither' configSettingsYmlBS
+
+-- | A version of @AppSettings@ parsed at compile time from @config/settings.yml@.
+compileTimeAppSettings :: AppSettings
+compileTimeAppSettings =
+ case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
+ Error e -> error e
+ Success settings -> settings
diff --git a/Settings/StaticFiles.hs b/Settings/StaticFiles.hs
new file mode 100644
index 0000000..bd29ca3
--- /dev/null
+++ b/Settings/StaticFiles.hs
@@ -0,0 +1,13 @@
+module Settings.StaticFiles where
+
+import Settings (appStaticDir, compileTimeAppSettings)
+import Yesod.EmbeddedStatic (mkEmbeddedStatic, embedDir)
+import Prelude (Bool(..), ($))
+
+#ifdef DEVELOPMENT
+#define DEV_BOOL True
+#else
+#define DEV_BOOL False
+#endif
+
+mkEmbeddedStatic DEV_BOOL "eStatic" [embedDir $ appStaticDir compileTimeAppSettings]
diff --git a/all.gup b/all.gup
new file mode 100644
index 0000000..1471462
--- /dev/null
+++ b/all.gup
@@ -0,0 +1,3 @@
+#!/usr/bin/env zsh
+
+gup -u bar.nix static/jquery.js static/webshim
diff --git a/app/DevelMain.hs b/app/DevelMain.hs
new file mode 100644
index 0000000..b327943
--- /dev/null
+++ b/app/DevelMain.hs
@@ -0,0 +1,99 @@
+-- | Running your app inside GHCi.
+--
+-- To start up GHCi for usage with Yesod, first make sure you are in dev mode:
+--
+-- > cabal configure -fdev
+--
+-- Note that @yesod devel@ automatically sets the dev flag.
+-- Now launch the repl:
+--
+-- > cabal repl --ghc-options="-O0 -fobject-code"
+--
+-- To start your app, run:
+--
+-- > :l DevelMain
+-- > DevelMain.update
+--
+-- You can also call @DevelMain.shutdown@ to stop the app
+--
+-- You will need to add the foreign-store package to your .cabal file.
+-- It is very light-weight.
+--
+-- If you don't use cabal repl, you will need
+-- to run the following in GHCi or to add it to
+-- your .ghci file.
+--
+-- :set -DDEVELOPMENT
+--
+-- 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 Control.Exception (finally)
+import Control.Monad ((>=>))
+import Control.Concurrent
+import Data.IORef
+import Foreign.Store
+import Network.Wai.Handler.Warp
+import GHC.Word
+
+-- | Start or restart the server.
+-- newStore is from foreign-store.
+-- A Store holds onto some data across ghci reloads
+update :: IO ()
+update = do
+ mtidStore <- lookupStore tidStoreNum
+ case mtidStore of
+ -- no server running
+ Nothing -> do
+ done <- storeAction doneStore newEmptyMVar
+ tid <- start done
+ _ <- storeAction (Store tidStoreNum) (newIORef tid)
+ return ()
+ -- server is already running
+ 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
+
+
+ -- | Start the server in a separate thread.
+ 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)
+ -- Note that this implies concurrency
+ -- between shutdownApp and the next app that is starting.
+ -- Normally this should be fine
+ (putMVar done () >> shutdownApp site))
+
+-- | kill the server
+shutdown :: IO ()
+shutdown = do
+ mtidStore <- lookupStore tidStoreNum
+ case mtidStore of
+ -- no server running
+ 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
diff --git a/app/devel.hs b/app/devel.hs
new file mode 100644
index 0000000..979103f
--- /dev/null
+++ b/app/devel.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE PackageImports #-}
+import "bar" Application (develMain)
+import Prelude (IO)
+
+main :: IO ()
+main = develMain
diff --git a/app/main.hs b/app/main.hs
new file mode 100644
index 0000000..4ffa93d
--- /dev/null
+++ b/app/main.hs
@@ -0,0 +1,5 @@
+import Prelude (IO)
+import Application (appMain)
+
+main :: IO ()
+main = appMain
diff --git a/bar.cabal b/bar.cabal
new file mode 100644
index 0000000..264339d
--- /dev/null
+++ b/bar.cabal
@@ -0,0 +1,128 @@
+name: bar
+version: 0.0.0
+cabal-version: >= 1.8
+build-type: Simple
+
+Flag dev
+ Description: Turn on development settings, like auto-reload templates.
+ Default: False
+
+Flag library-only
+ Description: Build for use with "yesod devel"
+ Default: False
+
+library
+ hs-source-dirs: ., app
+ exposed-modules: Application
+ Foundation
+ Import
+ Import.NoFoundation
+ Model
+ Settings
+ Settings.StaticFiles
+ Handler.Common
+ Handler.Common.Types
+ Handler.InventoryListing
+ Handler.UpdateItem
+ Handler.OpenItem
+ Handler.DeleteItem
+ Handler.Item
+
+ if flag(dev) || flag(library-only)
+ cpp-options: -DDEVELOPMENT
+ ghc-options: -Wall -fwarn-tabs -O0
+ else
+ ghc-options: -Wall -fwarn-tabs -O2
+
+ extensions: TemplateHaskell
+ QuasiQuotes
+ OverloadedStrings
+ NoImplicitPrelude
+ MultiParamTypeClasses
+ TypeFamilies
+ GADTs
+ GeneralizedNewtypeDeriving
+ FlexibleContexts
+ FlexibleInstances
+ EmptyDataDecls
+ NoMonomorphismRestriction
+ DeriveDataTypeable
+ ViewPatterns
+ TupleSections
+ RecordWildCards
+ CPP
+
+ build-depends:
+ -- Due to a bug in GHC 8.0.1, we block its usage
+ -- See: https://ghc.haskell.org/trac/ghc/ticket/12130
+ base >= 4.8.2.0 && < 4.9
+ || >= 4.9.1.0 && < 5
+
+ , yesod >= 1.4.3 && < 1.5
+ , yesod-core >= 1.4.30 && < 1.5
+ , yesod-auth >= 1.4.0 && < 1.5
+ , yesod-static >= 1.4.0.3 && < 1.6
+ , yesod-form >= 1.4.0 && < 1.5
+ , classy-prelude >= 0.10.2
+ , classy-prelude-conduit >= 0.10.2
+ -- version 1.0 had a bug in reexporting Handler, causing trouble
+ , classy-prelude-yesod >= 0.10.2 && < 1.0
+ || >= 1.1
+ , bytestring >= 0.9 && < 0.11
+ , text >= 0.11 && < 2.0
+ , persistent >= 2.0 && < 2.7
+ , persistent-postgresql >= 2.1.1 && < 2.7
+ , persistent-template >= 2.0 && < 2.7
+ , template-haskell
+ , shakespeare >= 2.0 && < 2.1
+ , hjsmin >= 0.1 && < 0.3
+ , monad-control >= 0.3 && < 1.1
+ , wai-extra >= 3.0 && < 3.1
+ , yaml >= 0.8 && < 0.9
+ , http-conduit >= 2.1 && < 2.3
+ , directory >= 1.1 && < 1.4
+ , warp >= 3.0 && < 3.3
+ , data-default
+ , aeson >= 0.6 && < 1.1
+ , conduit >= 1.0 && < 2.0
+ , monad-logger >= 0.3 && < 0.4
+ , fast-logger >= 2.2 && < 2.5
+ , wai-logger >= 2.2 && < 2.4
+ , file-embed
+ , safe
+ , unordered-containers
+ , containers
+ , vector
+ , time
+ , case-insensitive
+ , wai
+ , mtl
+ , lens
+
+executable bar
+ if flag(library-only)
+ Buildable: False
+
+ main-is: main.hs
+ hs-source-dirs: app
+ build-depends: base, bar
+
+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
+
+ extensions: TemplateHaskell
+ QuasiQuotes
+ OverloadedStrings
+ NoImplicitPrelude
+ MultiParamTypeClasses
+ TypeFamilies
+ GADTs
+ GeneralizedNewtypeDeriving
+ FlexibleContexts
+ FlexibleInstances
+ EmptyDataDecls
+ NoMonomorphismRestriction
+ DeriveDataTypeable
+ ViewPatterns
+ TupleSections
+ RecordWildCards
+ CPP
diff --git a/bar.nix b/bar.nix
new file mode 100644
index 0000000..ff25b88
--- /dev/null
+++ b/bar.nix
@@ -0,0 +1,30 @@
+{ mkDerivation, aeson, base, bytestring, case-insensitive
+, classy-prelude, classy-prelude-conduit, classy-prelude-yesod
+, conduit, containers, data-default, directory, fast-logger
+, file-embed, hjsmin, http-conduit, lens, monad-control
+, monad-logger, mtl, persistent, persistent-postgresql
+, persistent-template, safe, shakespeare, stdenv, template-haskell
+, text, time, unordered-containers, vector, wai, wai-extra
+, wai-logger, warp, yaml, yesod, yesod-auth, yesod-core, yesod-form
+, yesod-static
+}:
+mkDerivation {
+ pname = "bar";
+ version = "0.0.0";
+ src = ./.;
+ isLibrary = true;
+ isExecutable = true;
+ libraryHaskellDepends = [
+ aeson base bytestring case-insensitive classy-prelude
+ classy-prelude-conduit classy-prelude-yesod conduit containers
+ data-default directory fast-logger file-embed hjsmin http-conduit
+ lens monad-control monad-logger mtl persistent
+ persistent-postgresql persistent-template safe shakespeare
+ template-haskell text time unordered-containers vector wai
+ wai-extra wai-logger warp yaml yesod yesod-auth yesod-core
+ yesod-form yesod-static
+ ];
+ executableHaskellDepends = [ base ];
+ doHaddock = false;
+ license = stdenv.lib.licenses.unfree;
+}
diff --git a/bar.nix.gup b/bar.nix.gup
new file mode 100644
index 0000000..f0f9c74
--- /dev/null
+++ b/bar.nix.gup
@@ -0,0 +1,5 @@
+#!/usr/bin/env zsh
+
+gup -u ${2:r}.cabal
+cd ${2:h}
+cabal2nix --no-haddock ./. >! ${1}
diff --git a/config/models b/config/models
new file mode 100644
index 0000000..aa335df
--- /dev/null
+++ b/config/models
@@ -0,0 +1,12 @@
+Item
+ kind Text
+ normKind Text
+ bought Day Maybe
+ expires Day Maybe
+ opened Day Maybe
+ deriving Show Eq
+Reference
+ normKind Text
+ kind Text
+ UniqueKind normKind
+ deriving Show Eq Ord
\ No newline at end of file
diff --git a/config/routes b/config/routes
new file mode 100644
index 0000000..54d6593
--- /dev/null
+++ b/config/routes
@@ -0,0 +1,7 @@
+/static StaticR EmbeddedStatic appStatic
+
+/ InventoryListingR GET POST PUT
+/inv/#ItemId/edit UpdateItemR GET POST
+/inv/#ItemId/open OpenItemR POST
+/inv/#ItemId/delete DeleteItemR POST
+/inv/#ItemId ItemR GET PUT PATCH DELETE
diff --git a/config/settings.yml b/config/settings.yml
new file mode 100644
index 0000000..fcae60c
--- /dev/null
+++ b/config/settings.yml
@@ -0,0 +1,26 @@
+# Values formatted like "_env:ENV_VAR_NAME:default_value" can be overridden by the specified environment variable.
+# See https://github.com/yesodweb/yesod/wiki/Configuration#overriding-configuration-values-with-environment-variables
+
+static-dir: "_env:STATIC_DIR:static"
+host: "_env:HOST:*4" # any IPv4 host
+port: "_env:PORT:3000" # NB: The port `yesod devel` uses is distinct from this value. Set the `yesod devel` port from the command line.
+ip-from-header: "_env:IP_FROM_HEADER:false"
+
+# Default behavior: determine the application root from the request headers.
+# Uncomment to set an explicit approot
+approot: "_env:APPROOT:"
+
+# Optional values with the following production defaults.
+# In development, they default to the inverse.
+#
+# detailed-logging: false
+# should-log-all: false
+# reload-templates: false
+
+database:
+ user: "_env:PGUSER:bar"
+ password: "_env:PGPASS:"
+ host: "_env:PGHOST:"
+ port: "_env:PGPORT:"
+ database: "_env:PGDATABASE:bar"
+ poolsize: "_env:PGPOOLSIZE:10"
diff --git a/default.nix b/default.nix
new file mode 100644
index 0000000..1e631cf
--- /dev/null
+++ b/default.nix
@@ -0,0 +1,29 @@
+argumentPackages@{ ... }:
+
+let
+ defaultPackages = (import <nixpkgs> {}).haskellPackages;
+ haskellPackages = defaultPackages // argumentPackages;
+ pkgs = (import <nixpkgs> {}).pkgs // argumentPackages;
+
+ webshim = with pkgs; stdenv.mkDerivation rec {
+ name = "webshim-${version}";
+ version = "1.16.0";
+ src = fetchFromGitHub {
+ owner = "aFarkas";
+ repo = "webshim";
+ rev = "1.16.0";
+ sha256 = "14pk7hljqipzp0n7vpgcfxr3w4bla57cwyd7bmwmmxrm2zn62cyh";
+ };
+
+ installPhase = ''
+ mkdir -p $out/js
+ cp -r $src/js-webshim/dev/* $out/js/
+ '';
+ };
+in pkgs.stdenv.lib.overrideDerivation (haskellPackages.callPackage ./bar.nix {}) (oldAttrs: {
+ postUnpack = ''
+ rm -rf bar/static/jquery.js bar/static/webshim
+ ln -vs ${pkgs.jquery}/js/jquery.js bar/static
+ ln -vs ${webshim}/js bar/static/webshim
+ '';
+})
diff --git a/shell.nix b/shell.nix
new file mode 100644
index 0000000..b6595aa
--- /dev/null
+++ b/shell.nix
@@ -0,0 +1,18 @@
+{ nixpkgs ? import <nixpkgs> {}, compiler ? "default" }:
+
+let
+ inherit (nixpkgs) pkgs;
+
+ haskellPackages = if compiler == "default"
+ then pkgs.haskellPackages
+ else pkgs.haskell.packages.${compiler};
+
+ drv = haskellPackages.callPackage ./bar.nix {};
+in
+ pkgs.stdenv.lib.overrideDerivation drv.env (oldAttrs: {
+ buildInputs = oldAttrs.buildInputs ++ (with pkgs; [ cabal2nix gup haskellPackages.hlint haskellPackages.stack haskellPackages.yesod-bin ]);
+ shellHook = ''
+ ${oldAttrs.shellHook}
+ export PROMPT_INFO="${oldAttrs.name}"
+ '';
+ })
diff --git a/stack.yaml b/stack.yaml
new file mode 100644
index 0000000..776a6b4
--- /dev/null
+++ b/stack.yaml
@@ -0,0 +1,73 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# http://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+# resolver: ghcjs-0.1.0_ghc-7.10.2
+# resolver:
+# name: custom-snapshot
+# location: "./custom-snapshot.yaml"
+resolver: lts-8.5
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# - location:
+# git: https://github.com/commercialhaskell/stack.git
+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# extra-dep: true
+# subdirs:
+# - auto-update
+# - wai
+#
+# A package marked 'extra-dep: true' will only be built if demanded by a
+# non-dependency (i.e. a user package), and its test suites and benchmarks
+# will not be run. This is useful for tweaking upstream packages.
+packages:
+- '.'
+# Dependency packages to be pulled from upstream that are not in the resolver
+# (e.g., acme-missiles-0.3)
+extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+flags: {}
+
+# Extra package databases containing global packages
+extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=1.3"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor
+nix:
+ #enable: true
+ packages:
+ - postgresql
+ - zlib
+ - haskellPackages.yesod-bin
+ - haskellPackages.stack
diff --git a/static/jquery.js.gup b/static/jquery.js.gup
new file mode 100644
index 0000000..b6db680
--- /dev/null
+++ b/static/jquery.js.gup
@@ -0,0 +1,3 @@
+#!/usr/bin/env zsh
+
+curl -Ls "https://cdn.jsdelivr.net/jquery/3.1.1/jquery.js" >$1
\ No newline at end of file
diff --git a/static/webshim.gup b/static/webshim.gup
new file mode 100644
index 0000000..f9e205c
--- /dev/null
+++ b/static/webshim.gup
@@ -0,0 +1,6 @@
+#!/usr/bin/env zsh
+
+mkdir -p ${1}
+
+version="1.16.0"
+curl -Ls "https://github.com/aFarkas/webshim/archive/${version}.tar.gz" | tar -C ${1} -xz --strip-components=3 webshim-${version}/js-webshim/dev/
diff --git a/templates/default-layout-wrapper.hamlet b/templates/default-layout-wrapper.hamlet
new file mode 100644
index 0000000..dd317f1
--- /dev/null
+++ b/templates/default-layout-wrapper.hamlet
@@ -0,0 +1,15 @@
+$newline never
+$doctype 5
+<html lang="en">
+ <head>
+ <meta charset="UTF-8">
+
+ <title>#{pageTitle pc}
+ <meta name="description" content="">
+ <meta name="author" content="">
+
+ <meta name="viewport" content="width=device-width,initial-scale=1">
+
+ ^{pageHead pc}
+ <body>
+ ^{pageBody pc}
diff --git a/templates/default-layout.cassius b/templates/default-layout.cassius
new file mode 100644
index 0000000..492cde8
--- /dev/null
+++ b/templates/default-layout.cassius
@@ -0,0 +1,77 @@
+.table
+ display: table
+.table div
+ vertical-align: middle
+.td
+ display: table-cell
+ text-align: center
+ padding: 0.25em
+.tr
+ display: table-row
+.tc
+ display: table-caption
+ padding: 0.25em
+.th
+ display: table-cell
+ font-variant: small-caps
+ font-weight: bold
+ text-align: center
+ padding: 0.25em
+.kind
+ display: table-cell
+ text-align: left
+ padding: 0.25em
+.table .table .td, .table .table .tc, .table .table .th, .table .table .kind
+ padding: 0
+.error
+ background-color: #fdd
+ text-align: center
+ color: #c00
+ list-style-type: none
+button
+ width: 6em
+ display:inline-text
+.day hr
+ width: 2em
+ border: 1px solid #ddd
+ border-style: solid none solid none
+.sepBelow > div, .sepAbove > div
+ border: 2px none #ddd
+.sepBelow > div
+ border-bottom-style: solid
+.sepAbove > div
+ border-top-style: solid
+.color:nth-child(even)
+ background-color: #f0f0f0
+.color:nth-child(odd)
+ background-color: #fff
+body > div
+ margin: 0 auto
+.table > h1
+ display: table-caption
+nav ul
+ display:block
+ text-align: center
+ li
+ display:inline-block
+ font-variant: small-caps
+ font-size: 1.5em
+ font-weight: bold
+ a
+ text-decoration:none
+ color:#aaa
+ a:hover
+ color:inherit
+ li.active
+ a
+ color:inherit
+ li::before
+ content:" | "
+ color: #ddd
+ li:first-child::before
+ content:""
+label.checkbox
+ input
+ vertical-align: middle
+ span
+ vertical-align: middle
diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet
new file mode 100644
index 0000000..14c8cd5
--- /dev/null
+++ b/templates/default-layout.hamlet
@@ -0,0 +1,12 @@
+<nav>
+ <ul>
+ $forall MenuItem{..} <- menuItems
+ <li :Just menuItemRoute == mCurrentRoute:.active>
+ <a href=@{menuItemRoute}>#{menuItemLabel}
+
+$if not $ null msgs
+ <ul #messages>
+ $forall (status, msg) <- msgs
+ <li .#{status}>#{msg}
+
+^{widget}
diff --git a/templates/default-layout.julius b/templates/default-layout.julius
new file mode 100644
index 0000000..5ef6b42
--- /dev/null
+++ b/templates/default-layout.julius
@@ -0,0 +1,7 @@
+webshims.setOptions("forms-ext", {
+ "widgets": {
+ "classes": "hide-dropdownbtn"
+ }
+});
+webshims.activeLang("en-GB");
+webshims.polyfill("forms forms-ext");
diff --git a/templates/default-message-widget.hamlet b/templates/default-message-widget.hamlet
new file mode 100644
index 0000000..2eee196
--- /dev/null
+++ b/templates/default-message-widget.hamlet
@@ -0,0 +1,6 @@
+<div .container>
+ <div .row>
+ <div .col-md-2>
+ <div .col-md-8>
+ <h1>#{title}
+ ^{body}
diff --git a/templates/homepage.hamlet b/templates/homepage.hamlet
new file mode 100644
index 0000000..fb79965
--- /dev/null
+++ b/templates/homepage.hamlet
@@ -0,0 +1,139 @@
+<div .masthead>
+ <div .container>
+ <div .row>
+ <h1 .header>
+ Yesod—a modern framework for blazing fast websites
+ <h2>
+ Fast, stable & spiced with great community
+ <a href="http://www.yesodweb.com/book/" .btn.btn-info.btn-lg>
+ Read the Book
+
+<div .container>
+ <!-- Starting
+ ================================================== -->
+ <div .bs-docs-section>
+ <div .row>
+ <div .col-lg-12>
+ <div .page-header>
+ <h1 #start>Starting
+
+ <p>
+ Now that you have a working project you should use the
+ <a href=http://www.yesodweb.com/book/>Yesod book</a> to learn more.
+ <p>
+ You can also use this scaffolded site to explore some concepts, and best practices.
+
+ <ul .list-group>
+
+ <li .list-group-item>
+ This page was generated by the <tt>#{handlerName}</tt> handler in
+ <tt>Handler/Home.hs</tt>.
+
+ <li .list-group-item>
+ The <tt>#{handlerName}</tt> handler is set to generate your
+ site's home screen in Routes file
+ <tt>config/routes
+
+ <li .list-group-item>
+ We can link to other handlers, like the <a href="@{ProfileR}">Profile</a>.
+ Try it out as an anonymous user and see the access denied.
+ Then, try to <a href="@{AuthR LoginR}">login</a> with the dummy authentication added
+ while in development.
+
+ <li .list-group-item>
+ The HTML you are seeing now is actually composed by a number of <em>widgets</em>, #
+ most of them are brought together by the <tt>defaultLayout</tt> function which #
+ is defined in the <tt>Foundation.hs</tt> module, and used by <tt>#{handlerName}</tt>. #
+ All the files for templates and wigdets are in <tt>templates</tt>.
+
+ <li .list-group-item>
+ A Widget's Html, Css and Javascript are separated in three files with the
+ <tt>.hamlet</tt>, <tt>.lucius</tt> and <tt>.julius</tt> extensions.
+
+ <li .list-group-item ##{aDomId}>
+ If you had javascript enabled then you wouldn't be seeing this.
+
+ <hr>
+
+ <!-- Forms
+ ================================================== -->
+ <div .bs-docs-section>
+ <div .row>
+ <div .col-lg-12>
+ <div .page-header>
+ <h1 #forms>Forms
+
+ <p>
+ This is an example of a form. Read the
+ <a href="http://www.yesodweb.com/book/forms">Forms chapter</a> #
+ on the yesod book to learn more about them.
+
+ <div .row>
+ <div .col-lg-6>
+ <div .bs-callout bs-callout-info well>
+ <form .form-horizontal method=post action=@{HomeR}#forms enctype=#{formEnctype}>
+ ^{formWidget}
+
+ <button .btn.btn-primary type="submit">
+ Upload it!
+
+
+ <div .col-lg-4.col-lg-offset-1>
+ <div .bs-callout.bs-callout-info.upload-response>
+
+ $maybe (FileForm info con) <- submission
+ Your file type is <em>#{fileContentType info}</em>. You say it has: <em>#{con}</em>
+
+ $nothing
+ File upload result will be here...
+
+
+ <hr>
+
+ <!-- JSON
+ ================================================== -->
+ <div .bs-docs-section>
+ <div .row>
+ <div .col-lg-12>
+ <div .page-header>
+ <h1 #json>JSON
+
+ <p>
+ Yesod has JSON support baked-in.
+ The form below makes an AJAX request with Javascript,
+ then updates the page with your submission.
+ (see <tt>Handler/Comment.hs</tt>, <tt>templates/homepage.julius</tt>,
+ and <tt>Handler/Home.hs</tt> for the implementation).
+
+ <div .row>
+ <div .col-lg-6>
+ <div .bs-callout.bs-callout-info.well>
+ <form .form-horizontal ##{commentFormId}>
+ <div .field>
+ <textarea rows="2" ##{commentTextareaId} placeholder="Your comment here..." required></textarea>
+
+ <button .btn.btn-primary type=submit>
+ Create comment
+
+ <div .col-lg-4.col-lg-offset-1>
+ <div .bs-callout.bs-callout-info>
+ <small>
+ Your comments will appear here. You can also open the
+ console log to see the raw response from the server.
+ <ul ##{commentListId}>
+
+ <hr>
+
+ <!-- Testing
+ ================================================== -->
+ <div .bs-docs-section>
+ <div .row>
+ <div .col-lg-12>
+ <div .page-header>
+ <h1 #test>Testing
+
+ <p>
+ And last but not least, Testing. In <tt>test/Spec.hs</tt> you will find a #
+ test suite that performs tests on this page.
+ <p>
+ You can run your tests by doing: <code>stack test</code>
diff --git a/templates/homepage.julius b/templates/homepage.julius
new file mode 100644
index 0000000..865882e
--- /dev/null
+++ b/templates/homepage.julius
@@ -0,0 +1,34 @@
+document.getElementById(#{toJSON aDomId}).innerHTML = "This text was added by the Javascript part of the homepage widget.";
+
+$(function() {
+ $("##{rawJS commentFormId}").submit(function(event) {
+ event.preventDefault();
+
+ var message = $("##{rawJS commentTextareaId}").val();
+ // (Browsers that enforce the "required" attribute on the textarea won't see this alert)
+ if (!message) {
+ alert("Please fill out the comment form first.");
+ return;
+ }
+
+ // Make an AJAX request to the server to create a new comment
+ $.ajax({
+ url: '@{CommentR}',
+ type: 'POST',
+ contentType: "application/json",
+ data: JSON.stringify({
+ message: message,
+ }),
+ success: function (data) {
+ var newNode = $("<li></li>");
+ newNode.text(data.message);
+ console.log(data);
+ $("##{rawJS commentListId}").append(newNode);
+ },
+ error: function (data) {
+ console.log("Error creating comment: " + data);
+ },
+ });
+
+ });
+});
diff --git a/templates/homepage.lucius b/templates/homepage.lucius
new file mode 100644
index 0000000..3197fd5
--- /dev/null
+++ b/templates/homepage.lucius
@@ -0,0 +1,13 @@
+h2##{aDomId} {
+ color: #990
+}
+
+li {
+ line-height: 2em;
+ font-size: 16px
+}
+
+##{commentTextareaId} {
+ width: 400px;
+ height: 100px;
+}
diff --git a/templates/inventoryListing.hamlet b/templates/inventoryListing.hamlet
new file mode 100644
index 0000000..7c2c06b
--- /dev/null
+++ b/templates/inventoryListing.hamlet
@@ -0,0 +1,49 @@
+<div .table>
+ <div .tr .sepBelow>
+ <div .th>Description
+ <div .th>Bought
+ <div .th>Expires
+ <div .th>Opened
+ <div .th>Actions
+ $if isJust (preview insertForm =<< formState)
+ $with Just InsertForm{..} <- formState
+ <form .tr .sepBelow action=@{InventoryListingR} method=post enctype=#{fsInsertEncoding}>
+ ^{fsInsertForm}
+ <div .td>
+ <button type=submit>
+ Insert
+ $forall Entity itemId Item{..} <- stock
+ $if Just itemId == (preview updateItem =<< formState)
+ $with Just UpdateForm{..} <- formState
+ <form .tr .color action=@{UpdateItemR fsUpdateItem}##{toPathPiece fsUpdateItem} method=post enctype=#{fsUpdateEncoding} ##{toPathPiece fsUpdateItem}>
+ ^{fsUpdateForm}
+ <div .td>
+ <button type=submit>
+ Save Changes
+ $else
+ <div .tr .color ##{toPathPiece itemId}>
+ <div .kind>#{itemKind}
+ <div .td .day>
+ $maybe bought <- itemBought
+ #{dayFormat bought}
+ $nothing
+ <hr>
+ <div .td .day>
+ $maybe expires <- itemExpires
+ #{dayFormat expires}
+ $nothing
+ <hr>
+ <div .td .day>
+ $maybe opened <- itemOpened
+ #{dayFormat opened}
+ $nothing
+ <form method=post action=@{OpenItemR itemId}>
+ <button type=submit>
+ Open
+ <div .td>
+ <form method=get action=@{UpdateItemR itemId}##{toPathPiece itemId}>
+ <button type=submit>
+ Edit
+ <form method=post action=@{DeleteItemR itemId}>
+ <button type=submit>
+ Delete
diff --git a/templates/profile.hamlet b/templates/profile.hamlet
new file mode 100644
index 0000000..2420de6
--- /dev/null
+++ b/templates/profile.hamlet
@@ -0,0 +1,10 @@
+<div .ui.container>
+
+ <h1>
+ Access granted!
+
+ <p>
+ This page is protected and access is allowed only for authenticated users.
+
+ <p>
+ Your data is protected with us <strong><span class="username">#{userIdent user}</span></strong>!
--
cgit v1.2.3