summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.dir-locals.el4
-rw-r--r--.gitignore23
-rw-r--r--Application.hs180
-rw-r--r--Foundation.hs141
-rw-r--r--Handler/Common.hs78
-rw-r--r--Handler/Common/Types.hs23
-rw-r--r--Handler/DeleteItem.hs10
-rw-r--r--Handler/InventoryListing.hs26
-rw-r--r--Handler/Item.hs31
-rw-r--r--Handler/OpenItem.hs12
-rw-r--r--Handler/UpdateItem.hs33
-rw-r--r--Import.hs6
-rw-r--r--Import/NoFoundation.hs13
-rw-r--r--Model.hs96
-rw-r--r--Settings.hs107
-rw-r--r--Settings/StaticFiles.hs13
-rw-r--r--all.gup3
-rw-r--r--app/DevelMain.hs99
-rw-r--r--app/devel.hs6
-rw-r--r--app/main.hs5
-rw-r--r--bar.cabal128
-rw-r--r--bar.nix30
-rw-r--r--bar.nix.gup5
-rw-r--r--config/models12
-rw-r--r--config/routes7
-rw-r--r--config/settings.yml26
-rw-r--r--default.nix29
-rw-r--r--shell.nix18
-rw-r--r--stack.yaml73
-rw-r--r--static/jquery.js.gup3
-rw-r--r--static/webshim.gup6
-rw-r--r--templates/default-layout-wrapper.hamlet15
-rw-r--r--templates/default-layout.cassius77
-rw-r--r--templates/default-layout.hamlet12
-rw-r--r--templates/default-layout.julius7
-rw-r--r--templates/default-message-widget.hamlet6
-rw-r--r--templates/homepage.hamlet139
-rw-r--r--templates/homepage.julius34
-rw-r--r--templates/homepage.lucius13
-rw-r--r--templates/inventoryListing.hamlet49
-rw-r--r--templates/profile.hamlet10
41 files changed, 1608 insertions, 0 deletions
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 @@
1((haskell-mode . ((haskell-indent-spaces . 4)
2 (haskell-process-use-ghci . t)))
3 (hamlet-mode . ((hamlet/basic-offset . 4)
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 @@
1dist*
2static/tmp/
3static/combined/
4config/client_session_key.aes
5*.hi
6*.o
7*.sqlite3
8*.sqlite3-shm
9*.sqlite3-wal
10.hsenv*
11cabal-dev/
12.stack-work/
13yesod-devel/
14.cabal-sandbox
15cabal.sandbox.config
16.DS_Store
17*.swp
18*.keter
19**/result
20**/client_session_key.aes
21**/.gup
22static/webshim/
23static/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 @@
1{-# OPTIONS_GHC -fno-warn-orphans #-}
2module Application
3 ( getApplicationDev
4 , appMain
5 , develMain
6 , makeFoundation
7 , makeLogWare
8 -- * for DevelMain
9 , getApplicationRepl
10 , shutdownApp
11 -- * for GHCI
12 , handler
13 , db
14 ) where
15
16import Control.Monad.Logger (liftLoc, runLoggingT)
17import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr,
18 pgPoolSize, runSqlPool)
19import Import
20import Language.Haskell.TH.Syntax (qLocation)
21import Network.Wai (Middleware)
22import Network.Wai.Handler.Warp (Settings, defaultSettings,
23 defaultShouldDisplayException,
24 runSettings, setHost,
25 setOnException, setPort, getPort)
26import Network.Wai.Middleware.RequestLogger (Destination (Logger),
27 IPAddrSource (..),
28 OutputFormat (..), destination,
29 mkRequestLogger, outputFormat)
30import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet,
31 toLogStr)
32
33-- Import all relevant handler modules here.
34-- Don't forget to add new modules to your cabal file!
35import Handler.InventoryListing
36import Handler.UpdateItem
37import Handler.OpenItem
38import Handler.DeleteItem
39import Handler.Item
40
41-- This line actually creates our YesodDispatch instance. It is the second half
42-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
43-- comments there for more details.
44mkYesodDispatch "App" resourcesApp
45
46-- | This function allocates resources (such as a database connection pool),
47-- performs initialization and returns a foundation datatype value. This is also
48-- the place to put your migrate statements to have automatic database
49-- migrations handled by Yesod.
50makeFoundation :: AppSettings -> IO App
51makeFoundation appSettings = do
52 -- Some basic initializations: HTTP connection manager, logger, and static
53 -- subsite.
54 appHttpManager <- newManager
55 appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
56
57 -- We need a log function to create a connection pool. We need a connection
58 -- pool to create our foundation. And we need our foundation to get a
59 -- logging function. To get out of this loop, we initially create a
60 -- temporary foundation without a real connection pool, get a log function
61 -- from there, and then create the real foundation.
62 let mkFoundation appConnPool = App { appStatic = eStatic, ..}
63 -- The App {..} syntax is an example of record wild cards. For more
64 -- information, see:
65 -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
66 tempFoundation = mkFoundation $ error "connPool forced in tempFoundation"
67 logFunc = messageLoggerSource tempFoundation appLogger
68
69 -- Create the database connection pool
70 pool <- flip runLoggingT logFunc $ createPostgresqlPool
71 (pgConnStr $ appDatabaseConf appSettings)
72 (pgPoolSize $ appDatabaseConf appSettings)
73
74 -- Perform database migration using our application's logging settings.
75 runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
76
77 -- Return the foundation
78 return $ mkFoundation pool
79
80-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
81-- applying some additional middlewares.
82makeApplication :: App -> IO Application
83makeApplication foundation = do
84 logWare <- makeLogWare foundation
85 -- Create the WAI application and apply middlewares
86 appPlain <- toWaiAppPlain foundation
87 return $ logWare $ defaultMiddlewaresNoLogging appPlain
88
89makeLogWare :: App -> IO Middleware
90makeLogWare foundation =
91 mkRequestLogger def
92 { outputFormat =
93 if appDetailedRequestLogging $ appSettings foundation
94 then Detailed True
95 else Apache
96 (if appIpFromHeader $ appSettings foundation
97 then FromFallback
98 else FromSocket)
99 , destination = Logger $ loggerSet $ appLogger foundation
100 }
101
102
103-- | Warp settings for the given foundation value.
104warpSettings :: App -> Settings
105warpSettings foundation =
106 setPort (appPort $ appSettings foundation)
107 $ setHost (appHost $ appSettings foundation)
108 $ setOnException (\_req e ->
109 when (defaultShouldDisplayException e) $ messageLoggerSource
110 foundation
111 (appLogger foundation)
112 $(qLocation >>= liftLoc)
113 "yesod"
114 LevelError
115 (toLogStr $ "Exception from Warp: " ++ show e))
116 defaultSettings
117
118-- | For yesod devel, return the Warp settings and WAI Application.
119getApplicationDev :: IO (Settings, Application)
120getApplicationDev = do
121 settings <- getAppSettings
122 foundation <- makeFoundation settings
123 wsettings <- getDevSettings $ warpSettings foundation
124 app <- makeApplication foundation
125 return (wsettings, app)
126
127getAppSettings :: IO AppSettings
128getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv
129
130-- | main function for use by yesod devel
131develMain :: IO ()
132develMain = develMainHelper getApplicationDev
133
134-- | The @main@ function for an executable running this site.
135appMain :: IO ()
136appMain = do
137 -- Get the settings from all relevant sources
138 settings <- loadYamlSettingsArgs
139 -- fall back to compile-time values, set to [] to require values at runtime
140 [configSettingsYmlValue]
141
142 -- allow environment variables to override
143 useEnv
144
145 -- Generate the foundation from the settings
146 foundation <- makeFoundation settings
147
148 -- Generate a WAI Application from the foundation
149 app <- makeApplication foundation
150
151 -- Run the application with Warp
152 runSettings (warpSettings foundation) app
153
154
155--------------------------------------------------------------
156-- Functions for DevelMain.hs (a way to run the app from GHCi)
157--------------------------------------------------------------
158getApplicationRepl :: IO (Int, App, Application)
159getApplicationRepl = do
160 settings <- getAppSettings
161 foundation <- makeFoundation settings
162 wsettings <- getDevSettings $ warpSettings foundation
163 app1 <- makeApplication foundation
164 return (getPort wsettings, foundation, app1)
165
166shutdownApp :: App -> IO ()
167shutdownApp _ = return ()
168
169
170---------------------------------------------
171-- Functions for use in development with GHCi
172---------------------------------------------
173
174-- | Run a handler
175handler :: Handler a -> IO a
176handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h
177
178-- | Run DB queries
179db :: ReaderT SqlBackend (HandlerT App IO) a -> IO a
180db = 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 @@
1module Foundation where
2
3import Import.NoFoundation
4import Database.Persist.Sql (ConnectionPool, runSqlPool)
5import Text.Hamlet (hamletFile)
6
7import Yesod.Core.Types (Logger)
8import qualified Yesod.Core.Unsafe as Unsafe
9
10-- | The foundation datatype for your application. This can be a good place to
11-- keep settings and values requiring initialization before your application
12-- starts running, such as database connections. Every handler will have
13-- access to the data present here.
14data App = App
15 { appSettings :: AppSettings
16 , appStatic :: EmbeddedStatic
17 , appConnPool :: ConnectionPool -- ^ Database connection pool.
18 , appHttpManager :: Manager
19 , appLogger :: Logger
20 }
21
22data MenuItem = MenuItem
23 { menuItemLabel :: Text
24 , menuItemRoute :: Route App
25 }
26
27-- This is where we define all of the routes in our application. For a full
28-- explanation of the syntax, please see:
29-- http://www.yesodweb.com/book/routing-and-handlers
30--
31-- Note that this is really half the story; in Application.hs, mkYesodDispatch
32-- generates the rest of the code. Please see the following documentation
33-- for an explanation for this split:
34-- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules
35--
36-- This function also generates the following type synonyms:
37-- type Handler = HandlerT App IO
38-- type Widget = WidgetT App IO ()
39mkYesodData "App" $(parseRoutesFile "config/routes")
40
41-- | A convenient synonym for creating forms.
42type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
43
44-- Please see the documentation for the Yesod typeclass. There are a number
45-- of settings which can be configured by overriding methods here.
46instance Yesod App where
47 -- Controls the base of generated URLs. For more information on modifying,
48 -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
49 approot = ApprootRequest $ \app req ->
50 case appRoot $ appSettings app of
51 Nothing -> getApprootText guessApproot app req
52 Just root -> root
53
54 -- Store session data on the client in encrypted cookies,
55 -- default session idle timeout is 120 minutes
56 makeSessionBackend _ = Just <$> defaultClientSessionBackend
57 120 -- timeout in minutes
58 "client_session_key.aes"
59
60 -- Yesod Middleware allows you to run code before and after each handler function.
61
62 -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
63 -- Some users may also want to add the defaultCsrfMiddleware, which:
64 -- a) Sets a cookie with a CSRF token in it.
65 -- b) Validates that incoming write requests include that token in either a header or POST parameter.
66 -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
67 -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
68 yesodMiddleware = defaultYesodMiddleware
69
70 defaultLayout widget = do
71 msgs <- getMessages
72
73 mCurrentRoute <- getCurrentRoute
74
75 -- Define the menu items of the header.
76 let menuItems =
77 [ MenuItem "Inventory" InventoryListingR
78 ]
79
80 -- We break up the default layout into two components:
81 -- default-layout is the contents of the body tag, and
82 -- default-layout-wrapper is the entire page. Since the final
83 -- value passed to hamletToRepHtml cannot be a widget, this allows
84 -- you to use normal widget features in default-layout.
85
86 pc <- widgetToPageContent $ do
87 addScript $ StaticR jquery_js
88 addScript $ StaticR webshim_polyfiller_js
89 $(widgetFile "default-layout")
90 withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
91
92
93 -- This function creates static content files in the static folder
94 -- and names them based on a hash of their content. This allows
95 -- expiration dates to be set far in the future without worry of
96 -- users receiving stale content.
97 addStaticContent = embedStaticContent appStatic StaticR Right
98
99 -- What messages should be logged. The following includes all messages when
100 -- in development, and warnings and errors in production.
101 shouldLog app _source level =
102 appShouldLogAll (appSettings app)
103 || level == LevelWarn
104 || level == LevelError
105
106 makeLogger = return . appLogger
107
108 -- Provide proper Bootstrap styling for default displays, like
109 -- error pages
110 defaultMessageWidget title body = $(widgetFile "default-message-widget")
111
112-- How to run database actions.
113instance YesodPersist App where
114 type YesodPersistBackend App = SqlBackend
115 runDB action = do
116 master <- getYesod
117 runSqlPool action $ appConnPool master
118instance YesodPersistRunner App where
119 getDBRunner = defaultGetDBRunner appConnPool
120
121-- This instance is required to use forms. You can modify renderMessage to
122-- achieve customized and internationalized form validation messages.
123instance RenderMessage App FormMessage where
124 renderMessage _ _ = defaultFormMessage
125
126-- Useful when writing code that is re-usable outside of the Handler context.
127-- An example is background jobs that send email.
128-- This can also be useful for writing code that works across multiple Yesod applications.
129instance HasHttpManager App where
130 getHttpManager = appHttpManager
131
132unsafeHandler :: App -> Handler a -> IO a
133unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
134
135-- Note: Some functionality previously present in the scaffolding has been
136-- moved to documentation in the Wiki. Following are some hopefully helpful
137-- links:
138--
139-- https://github.com/yesodweb/yesod/wiki/Sending-email
140-- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain
141-- 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 @@
1{-# LANGUAGE ApplicativeDo #-}
2
3module Handler.Common
4 ( inventoryListing
5 , itemForm
6 , InventoryState(..)
7 , FormState(..)
8 ) where
9
10import Import
11
12import Data.Unique
13
14import qualified Data.Text as Text (pack)
15
16import Control.Lens
17
18import Handler.Common.Types
19
20dayFormat :: Day -> String
21dayFormat = formatTime defaultTimeLocale "%e. %b %y"
22
23itemForm :: Maybe Item -- ^ Update existing item or insert new?
24 -> Html -> MForm Handler (FormResult Item, Widget)
25itemForm proto identView = do
26 today <- utctDay <$> liftIO getCurrentTime
27
28 (kindRes, kindView) <- mreq textField "" $ itemKind <$> proto
29 (boughtRes, boughtWidget) <- dayForm (maybe (Just $ Just today) Just $ fmap itemBought proto) "Unknown"
30 (expiresRes, expiresWidget) <- dayForm (fmap itemExpires proto) "Never"
31 (openedRes, openedWidget) <- dayForm (fmap itemOpened proto) "Never"
32
33 let itemRes = do
34 itemKind <- kindRes
35 itemBought <- boughtRes
36 itemExpires <- expiresRes
37 itemOpened <- openedRes
38 return Item{ itemNormKind = normalizeKind itemKind, ..}
39
40 return . (itemRes, ) $
41 [whamlet|
42 $newline never
43 #{identView}
44 <div .td>^{fvInput kindView}
45 <div .td>^{boughtWidget}
46 <div .td>^{expiresWidget}
47 <div .td>^{openedWidget}
48 |]
49 where
50 dayForm :: Maybe (Maybe Day) -> String -> MForm Handler (FormResult (Maybe Day), Widget)
51 dayForm proto label = do
52 today <- utctDay <$> liftIO getCurrentTime
53
54 checkboxId <- ("check" <>) . show . hashUnique <$> liftIO newUnique
55
56 (fmap (fromMaybe False) -> isNothingRes, isNothingView) <-
57 mopt checkBoxField ("" { fsId = Just $ Text.pack checkboxId }) . Just . Just . fromMaybe True $ fmap isNothing proto
58 (dayRes, dayView) <-
59 mreq dayField "" . Just . fromMaybe today $ join proto
60
61 let res = (bool Just (const Nothing) <$> isNothingRes) <*> dayRes
62 return . (res, ) $ do
63 [whamlet|
64 $newline never
65 <div .table>
66 <div .tr>
67 <label for=#{checkboxId} .checkbox .td>
68 ^{fvInput isNothingView}
69 <span>
70 #{label}
71 <div .tr>
72 <div .td .dayInput>^{fvInput dayView}
73 |]
74
75inventoryListing :: InventoryState -> Widget
76inventoryListing InventoryState{..} = do
77 setTitle "Bar Inventory"
78 $(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 @@
1{-# LANGUAGE FunctionalDependencies #-}
2
3module Handler.Common.Types where
4
5import Import
6
7import Control.Lens
8
9data InventoryState = InventoryState
10 { stock :: [Entity Item]
11 , formState :: Maybe FormState
12 }
13
14data FormState = InsertForm
15 { fsInsertForm :: Widget
16 , fsInsertEncoding :: Enctype
17 }
18 | UpdateForm
19 { fsUpdateItem :: ItemId
20 , fsUpdateForm :: Widget
21 , fsUpdateEncoding :: Enctype
22 }
23makeLensesWith 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 @@
1module Handler.DeleteItem where
2
3import Import
4
5postDeleteItemR :: ItemId -> Handler TypedContent
6postDeleteItemR itemId = do
7 runDB $ delete itemId
8 selectRep $ do
9 provideJson ()
10 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 @@
1module Handler.InventoryListing where
2
3import Import
4import Handler.Common
5
6getInventoryListingR, postInventoryListingR :: Handler TypedContent
7getInventoryListingR = postInventoryListingR
8postInventoryListingR = do
9 ((insertResult, fsInsertForm), fsInsertEncoding) <- runFormPost $ itemForm Nothing
10
11 mapM_ (addMessage "formError" . toHtml) =<< case insertResult of
12 FormSuccess newItem -> [] <$ runDB (insert newItem)
13 FormFailure errors -> return errors
14 _ -> return []
15
16 (sortOn entityVal -> stock) <- runDB $ selectList [] []
17
18 selectRep $ do
19 provideJson (stock :: [Entity Item])
20 provideRep . defaultLayout $ inventoryListing InventoryState
21 { formState = Just InsertForm{..}
22 , ..
23 }
24
25putInventoryListingR :: Handler Value
26putInventoryListingR = 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 @@
1module Handler.Item where
2
3import Import
4
5getItemR :: ItemId -> Handler TypedContent
6getItemR itemId = do
7 eLookup <- runDB $ fmap (Entity itemId) <$> get itemId
8 case eLookup of
9 Nothing -> notFound
10 Just entity -> selectRep $ do
11 provideJson entity
12 provideRep (redirect $ InventoryListingR :#: itemId :: Handler Html)
13
14putItemR :: ItemId -> Handler Value
15putItemR itemId = do
16 Item{..} <- requireCheckJsonBody
17 returnJson . Entity itemId =<< runDB
18 (updateGet itemId [ ItemKind =. itemKind
19 , ItemNormKind =. itemNormKind
20 , ItemBought =. itemBought
21 , ItemExpires =. itemExpires
22 , ItemOpened =. itemOpened
23 ])
24
25patchItemR :: ItemId -> Handler Value
26patchItemR itemId = do
27 diffs <- (requireCheckJsonBody :: Handler ItemDiffs)
28 returnJson . Entity itemId =<< runDB (updateGet itemId $ toUpdate diffs)
29
30deleteItemR :: ItemId -> Handler ()
31deleteItemR = 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 @@
1module Handler.OpenItem where
2
3import Import
4
5postOpenItemR :: ItemId -> Handler TypedContent
6postOpenItemR itemId = do
7 today <- utctDay <$> liftIO getCurrentTime
8 result <- fmap (Entity itemId) . runDB $ updateGet itemId [ ItemOpened =. Just today
9 ]
10 selectRep $ do
11 provideJson result
12 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 @@
1module Handler.UpdateItem where
2
3import Import
4
5import Handler.Common
6
7getUpdateItemR, postUpdateItemR :: ItemId -> Handler TypedContent
8getUpdateItemR = postUpdateItemR
9postUpdateItemR fsUpdateItem = do
10 Just entity <- fmap (Entity fsUpdateItem) <$> runDB (get fsUpdateItem)
11
12 ((updateResult, fsUpdateForm), fsUpdateEncoding) <- runFormPost . itemForm . Just $ entityVal entity
13
14 mapM_ (addMessage "formError" . toHtml) =<< case updateResult of
15 FormSuccess Item{..} -> [] <$ runDB (update fsUpdateItem [ ItemKind =. itemKind
16 , ItemNormKind =. normalizeKind itemKind
17 , ItemBought =. itemBought
18 , ItemExpires =. itemExpires
19 , ItemOpened =. itemOpened
20 ])
21 FormFailure errors -> return errors
22 _ -> return []
23
24 selectRep $ do
25 provideRep $ case updateResult of
26 FormSuccess _ -> redirect $ InventoryListingR :#: fsUpdateItem :: Handler Html
27 _ -> do
28 (sortOn entityVal -> stock) <- runDB $ selectList [] []
29 defaultLayout $ inventoryListing InventoryState
30 { formState = Just UpdateForm{..}
31 , ..
32 }
33 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 @@
1module Import
2 ( module Import
3 ) where
4
5import Foundation as Import
6import 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 @@
1{-# LANGUAGE CPP #-}
2module Import.NoFoundation
3 ( module Import
4 ) where
5
6import ClassyPrelude.Yesod as Import
7import Model as Import
8import Settings as Import
9import Settings.StaticFiles as Import
10import Yesod.Auth as Import
11import Yesod.Core.Types as Import (loggerSet)
12import Yesod.Default.Config2 as Import
13import 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 @@
1{-# LANGUAGE FlexibleInstances #-}
2
3module Model where
4
5import ClassyPrelude.Yesod
6import Database.Persist.Quasi
7
8import Control.Monad.Writer
9
10import Data.Text (Text)
11import qualified Data.Text as Text
12
13import Data.Aeson
14
15-- You can define all of your database entities in the entities file.
16-- You can find more information on persistent and how to declare entities
17-- at:
18-- http://www.yesodweb.com/book/persistent/
19share [mkPersist sqlSettings, mkMigrate "migrateAll"]
20 $(persistFileWith lowerCaseSettings "config/models")
21
22instance Ord Item where
23 x `compare` y = mconcat
24 [ (isNothing $ itemOpened x) `compare` (isNothing $ itemOpened y)
25 , itemOpened x `compare` itemOpened y
26 , (isNothing $ itemExpires x) `compare` (isNothing $ itemExpires y)
27 , itemExpires x `compare` itemExpires x
28 , itemKind x `compare` itemKind x
29 , itemBought x `compare` itemBought x
30 ]
31
32instance ToJSON Item where
33 toJSON Item{..} = object $
34 [ "kind" .= itemKind
35 ] ++ maybe [] (\x -> ["bought" .= x]) itemBought
36 ++ maybe [] (\x -> ["expires" .= x]) itemExpires
37 ++ maybe [] (\x -> ["opened" .= x]) itemOpened
38
39instance FromJSON Item where
40 parseJSON = withObject "Item" $ \obj -> do
41 itemKind <- obj .: "kind"
42 let
43 itemNormKind = normalizeKind itemKind
44 itemBought <- obj .:? "bought"
45 itemExpires <- obj .:? "expires"
46 itemOpened <- obj .:? "opened"
47 return Item{..}
48
49instance ToJSON (Entity Item) where
50 toJSON = entityIdToJSON
51
52instance FromJSON (Entity Item) where
53 parseJSON = entityIdFromJSON
54
55instance ToJSON Reference where
56 toJSON Reference{..} = String referenceKind
57
58instance FromJSON Reference where
59 parseJSON = withText "Reference" $ \referenceKind -> do
60 let
61 referenceNormKind = normalizeKind referenceKind
62 return Reference{..}
63
64instance ToJSON (Entity Reference) where
65 toJSON = keyValueEntityToJSON
66
67instance FromJSON (Entity Reference) where
68 parseJSON = keyValueEntityFromJSON
69
70normalizeKind :: Text -> Text
71normalizeKind = Text.strip . Text.toCaseFold
72
73data ItemDiff = DiffKind Text
74 | DiffBought (Maybe Day)
75 | DiffExpires (Maybe Day)
76 | DiffOpened (Maybe Day)
77
78newtype ItemDiffs = ItemDiffs [ItemDiff]
79
80instance FromJSON ItemDiffs where
81 parseJSON = withObject "ItemDiff" $ \obj -> fmap ItemDiffs . execWriterT $ do
82 tell =<< maybe [] (pure . DiffKind) <$> lift (obj .:? "kind")
83 tell =<< maybe [] (pure . DiffBought) <$> lift (obj .:! "bought")
84 tell =<< maybe [] (pure . DiffExpires) <$> lift (obj .:! "expires")
85 tell =<< maybe [] (pure . DiffOpened) <$> lift (obj .:! "opened")
86
87toUpdate :: ItemDiffs -> [Update Item]
88toUpdate (ItemDiffs ds) = do
89 x <- ds
90 case x of
91 DiffKind t -> [ ItemKind =. t
92 , ItemNormKind =. normalizeKind t
93 ]
94 DiffBought d -> [ ItemBought =. d ]
95 DiffExpires d -> [ ItemExpires =. d ]
96 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 @@
1{-# Language CPP #-}
2-- | Settings are centralized, as much as possible, into this file. This
3-- includes database connection settings, static file locations, etc.
4-- In addition, you can configure a number of different aspects of Yesod
5-- by overriding methods in the Yesod typeclass. That instance is
6-- declared in the Foundation.hs file.
7module Settings where
8
9import ClassyPrelude.Yesod
10import qualified Control.Exception as Exception
11import Data.Aeson (Result (..), fromJSON, withObject, (.!=),
12 (.:?))
13import Data.FileEmbed (embedFile)
14import Data.Yaml (decodeEither')
15import Database.Persist.Postgresql (PostgresConf)
16import Language.Haskell.TH.Syntax (Exp, Q)
17import Network.Wai.Handler.Warp (HostPreference)
18import Yesod.Default.Config2 (applyEnvValue, configSettingsYml)
19import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload,
20 widgetFileReload)
21
22#ifdef DEVELOPMENT
23#define DEV_BOOL True
24#else
25#define DEV_BOOL False
26#endif
27
28-- | Runtime settings to configure this application. These settings can be
29-- loaded from various sources: defaults, environment variables, config files,
30-- theoretically even a database.
31data AppSettings = AppSettings
32 { appStaticDir :: String
33 -- ^ Directory from which to serve static files.
34 , appDatabaseConf :: PostgresConf
35 -- ^ Configuration settings for accessing the database.
36 , appRoot :: Maybe Text
37 -- ^ Base for all generated URLs. If @Nothing@, determined
38 -- from the request headers.
39 , appHost :: HostPreference
40 -- ^ Host/interface the server should bind to.
41 , appPort :: Int
42 -- ^ Port to listen on
43 , appIpFromHeader :: Bool
44 -- ^ Get the IP address from the header when logging. Useful when sitting
45 -- behind a reverse proxy.
46
47 , appDetailedRequestLogging :: Bool
48 -- ^ Use detailed request logging system
49 , appShouldLogAll :: Bool
50 -- ^ Should all log messages be displayed?
51 , appReloadTemplates :: Bool
52 -- ^ Use the reload version of templates
53 }
54
55instance FromJSON AppSettings where
56 parseJSON = withObject "AppSettings" $ \o -> do
57 let defaultDev = DEV_BOOL
58 appStaticDir <- o .: "static-dir"
59 appDatabaseConf <- o .: "database"
60 appRoot <- o .:? "approot"
61 appHost <- fromString <$> o .: "host"
62 appPort <- o .: "port"
63 appIpFromHeader <- o .: "ip-from-header"
64
65 appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
66 appShouldLogAll <- o .:? "should-log-all" .!= defaultDev
67 appReloadTemplates <- o .:? "reload-templates" .!= defaultDev
68
69 return AppSettings {..}
70
71-- | Settings for 'widgetFile', such as which template languages to support and
72-- default Hamlet settings.
73--
74-- For more information on modifying behavior, see:
75--
76-- https://github.com/yesodweb/yesod/wiki/Overriding-widgetFile
77widgetFileSettings :: WidgetFileSettings
78widgetFileSettings = def
79
80-- | How static files should be combined.
81combineSettings :: CombineSettings
82combineSettings = def
83
84-- The rest of this file contains settings which rarely need changing by a
85-- user.
86
87widgetFile :: String -> Q Exp
88widgetFile = (if appReloadTemplates compileTimeAppSettings
89 then widgetFileReload
90 else widgetFileNoReload)
91 widgetFileSettings
92
93-- | Raw bytes at compile time of @config/settings.yml@
94configSettingsYmlBS :: ByteString
95configSettingsYmlBS = $(embedFile configSettingsYml)
96
97-- | @config/settings.yml@, parsed to a @Value@.
98configSettingsYmlValue :: Value
99configSettingsYmlValue = either Exception.throw id
100 $ decodeEither' configSettingsYmlBS
101
102-- | A version of @AppSettings@ parsed at compile time from @config/settings.yml@.
103compileTimeAppSettings :: AppSettings
104compileTimeAppSettings =
105 case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
106 Error e -> error e
107 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 @@
1module Settings.StaticFiles where
2
3import Settings (appStaticDir, compileTimeAppSettings)
4import Yesod.EmbeddedStatic (mkEmbeddedStatic, embedDir)
5import Prelude (Bool(..), ($))
6
7#ifdef DEVELOPMENT
8#define DEV_BOOL True
9#else
10#define DEV_BOOL False
11#endif
12
13mkEmbeddedStatic 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 @@
1#!/usr/bin/env zsh
2
3gup -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 @@
1-- | Running your app inside GHCi.
2--
3-- To start up GHCi for usage with Yesod, first make sure you are in dev mode:
4--
5-- > cabal configure -fdev
6--
7-- Note that @yesod devel@ automatically sets the dev flag.
8-- Now launch the repl:
9--
10-- > cabal repl --ghc-options="-O0 -fobject-code"
11--
12-- To start your app, run:
13--
14-- > :l DevelMain
15-- > DevelMain.update
16--
17-- You can also call @DevelMain.shutdown@ to stop the app
18--
19-- You will need to add the foreign-store package to your .cabal file.
20-- It is very light-weight.
21--
22-- If you don't use cabal repl, you will need
23-- to run the following in GHCi or to add it to
24-- your .ghci file.
25--
26-- :set -DDEVELOPMENT
27--
28-- There is more information about this approach,
29-- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci
30
31module DevelMain where
32
33import Prelude
34import Application (getApplicationRepl, shutdownApp)
35
36import Control.Exception (finally)
37import Control.Monad ((>=>))
38import Control.Concurrent
39import Data.IORef
40import Foreign.Store
41import Network.Wai.Handler.Warp
42import GHC.Word
43
44-- | Start or restart the server.
45-- newStore is from foreign-store.
46-- A Store holds onto some data across ghci reloads
47update :: IO ()
48update = do
49 mtidStore <- lookupStore tidStoreNum
50 case mtidStore of
51 -- no server running
52 Nothing -> do
53 done <- storeAction doneStore newEmptyMVar
54 tid <- start done
55 _ <- storeAction (Store tidStoreNum) (newIORef tid)
56 return ()
57 -- server is already running
58 Just tidStore -> restartAppInNewThread tidStore
59 where
60 doneStore :: Store (MVar ())
61 doneStore = Store 0
62
63 -- shut the server down with killThread and wait for the done signal
64 restartAppInNewThread :: Store (IORef ThreadId) -> IO ()
65 restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do
66 killThread tid
67 withStore doneStore takeMVar
68 readStore doneStore >>= start
69
70
71 -- | Start the server in a separate thread.
72 start :: MVar () -- ^ Written to when the thread is killed.
73 -> IO ThreadId
74 start done = do
75 (port, site, app) <- getApplicationRepl
76 forkIO (finally (runSettings (setPort port defaultSettings) app)
77 -- Note that this implies concurrency
78 -- between shutdownApp and the next app that is starting.
79 -- Normally this should be fine
80 (putMVar done () >> shutdownApp site))
81
82-- | kill the server
83shutdown :: IO ()
84shutdown = do
85 mtidStore <- lookupStore tidStoreNum
86 case mtidStore of
87 -- no server running
88 Nothing -> putStrLn "no Yesod app running"
89 Just tidStore -> do
90 withStore tidStore $ readIORef >=> killThread
91 putStrLn "Yesod app is shutdown"
92
93tidStoreNum :: Word32
94tidStoreNum = 1
95
96modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO ()
97modifyStoredIORef store f = withStore store $ \ref -> do
98 v <- readIORef ref
99 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 @@
1{-# LANGUAGE PackageImports #-}
2import "bar" Application (develMain)
3import Prelude (IO)
4
5main :: IO ()
6main = 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 @@
1import Prelude (IO)
2import Application (appMain)
3
4main :: IO ()
5main = 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 @@
1name: bar
2version: 0.0.0
3cabal-version: >= 1.8
4build-type: Simple
5
6Flag dev
7 Description: Turn on development settings, like auto-reload templates.
8 Default: False
9
10Flag library-only
11 Description: Build for use with "yesod devel"
12 Default: False
13
14library
15 hs-source-dirs: ., app
16 exposed-modules: Application
17 Foundation
18 Import
19 Import.NoFoundation
20 Model
21 Settings
22 Settings.StaticFiles
23 Handler.Common
24 Handler.Common.Types
25 Handler.InventoryListing
26 Handler.UpdateItem
27 Handler.OpenItem
28 Handler.DeleteItem
29 Handler.Item
30
31 if flag(dev) || flag(library-only)
32 cpp-options: -DDEVELOPMENT
33 ghc-options: -Wall -fwarn-tabs -O0
34 else
35 ghc-options: -Wall -fwarn-tabs -O2
36
37 extensions: TemplateHaskell
38 QuasiQuotes
39 OverloadedStrings
40 NoImplicitPrelude
41 MultiParamTypeClasses
42 TypeFamilies
43 GADTs
44 GeneralizedNewtypeDeriving
45 FlexibleContexts
46 FlexibleInstances
47 EmptyDataDecls
48 NoMonomorphismRestriction
49 DeriveDataTypeable
50 ViewPatterns
51 TupleSections
52 RecordWildCards
53 CPP
54
55 build-depends:
56 -- Due to a bug in GHC 8.0.1, we block its usage
57 -- See: https://ghc.haskell.org/trac/ghc/ticket/12130
58 base >= 4.8.2.0 && < 4.9
59 || >= 4.9.1.0 && < 5
60
61 , yesod >= 1.4.3 && < 1.5
62 , yesod-core >= 1.4.30 && < 1.5
63 , yesod-auth >= 1.4.0 && < 1.5
64 , yesod-static >= 1.4.0.3 && < 1.6
65 , yesod-form >= 1.4.0 && < 1.5
66 , classy-prelude >= 0.10.2
67 , classy-prelude-conduit >= 0.10.2
68 -- version 1.0 had a bug in reexporting Handler, causing trouble
69 , classy-prelude-yesod >= 0.10.2 && < 1.0
70 || >= 1.1
71 , bytestring >= 0.9 && < 0.11
72 , text >= 0.11 && < 2.0
73 , persistent >= 2.0 && < 2.7
74 , persistent-postgresql >= 2.1.1 && < 2.7
75 , persistent-template >= 2.0 && < 2.7
76 , template-haskell
77 , shakespeare >= 2.0 && < 2.1
78 , hjsmin >= 0.1 && < 0.3
79 , monad-control >= 0.3 && < 1.1
80 , wai-extra >= 3.0 && < 3.1
81 , yaml >= 0.8 && < 0.9
82 , http-conduit >= 2.1 && < 2.3
83 , directory >= 1.1 && < 1.4
84 , warp >= 3.0 && < 3.3
85 , data-default
86 , aeson >= 0.6 && < 1.1
87 , conduit >= 1.0 && < 2.0
88 , monad-logger >= 0.3 && < 0.4
89 , fast-logger >= 2.2 && < 2.5
90 , wai-logger >= 2.2 && < 2.4
91 , file-embed
92 , safe
93 , unordered-containers
94 , containers
95 , vector
96 , time
97 , case-insensitive
98 , wai
99 , mtl
100 , lens
101
102executable bar
103 if flag(library-only)
104 Buildable: False
105
106 main-is: main.hs
107 hs-source-dirs: app
108 build-depends: base, bar
109
110 ghc-options: -threaded -rtsopts -with-rtsopts=-N
111
112 extensions: TemplateHaskell
113 QuasiQuotes
114 OverloadedStrings
115 NoImplicitPrelude
116 MultiParamTypeClasses
117 TypeFamilies
118 GADTs
119 GeneralizedNewtypeDeriving
120 FlexibleContexts
121 FlexibleInstances
122 EmptyDataDecls
123 NoMonomorphismRestriction
124 DeriveDataTypeable
125 ViewPatterns
126 TupleSections
127 RecordWildCards
128 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 @@
1{ mkDerivation, aeson, base, bytestring, case-insensitive
2, classy-prelude, classy-prelude-conduit, classy-prelude-yesod
3, conduit, containers, data-default, directory, fast-logger
4, file-embed, hjsmin, http-conduit, lens, monad-control
5, monad-logger, mtl, persistent, persistent-postgresql
6, persistent-template, safe, shakespeare, stdenv, template-haskell
7, text, time, unordered-containers, vector, wai, wai-extra
8, wai-logger, warp, yaml, yesod, yesod-auth, yesod-core, yesod-form
9, yesod-static
10}:
11mkDerivation {
12 pname = "bar";
13 version = "0.0.0";
14 src = ./.;
15 isLibrary = true;
16 isExecutable = true;
17 libraryHaskellDepends = [
18 aeson base bytestring case-insensitive classy-prelude
19 classy-prelude-conduit classy-prelude-yesod conduit containers
20 data-default directory fast-logger file-embed hjsmin http-conduit
21 lens monad-control monad-logger mtl persistent
22 persistent-postgresql persistent-template safe shakespeare
23 template-haskell text time unordered-containers vector wai
24 wai-extra wai-logger warp yaml yesod yesod-auth yesod-core
25 yesod-form yesod-static
26 ];
27 executableHaskellDepends = [ base ];
28 doHaddock = false;
29 license = stdenv.lib.licenses.unfree;
30}
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 @@
1#!/usr/bin/env zsh
2
3gup -u ${2:r}.cabal
4cd ${2:h}
5cabal2nix --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 @@
1Item
2 kind Text
3 normKind Text
4 bought Day Maybe
5 expires Day Maybe
6 opened Day Maybe
7 deriving Show Eq
8Reference
9 normKind Text
10 kind Text
11 UniqueKind normKind
12 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 @@
1/static StaticR EmbeddedStatic appStatic
2
3/ InventoryListingR GET POST PUT
4/inv/#ItemId/edit UpdateItemR GET POST
5/inv/#ItemId/open OpenItemR POST
6/inv/#ItemId/delete DeleteItemR POST
7/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 @@
1# Values formatted like "_env:ENV_VAR_NAME:default_value" can be overridden by the specified environment variable.
2# See https://github.com/yesodweb/yesod/wiki/Configuration#overriding-configuration-values-with-environment-variables
3
4static-dir: "_env:STATIC_DIR:static"
5host: "_env:HOST:*4" # any IPv4 host
6port: "_env:PORT:3000" # NB: The port `yesod devel` uses is distinct from this value. Set the `yesod devel` port from the command line.
7ip-from-header: "_env:IP_FROM_HEADER:false"
8
9# Default behavior: determine the application root from the request headers.
10# Uncomment to set an explicit approot
11approot: "_env:APPROOT:"
12
13# Optional values with the following production defaults.
14# In development, they default to the inverse.
15#
16# detailed-logging: false
17# should-log-all: false
18# reload-templates: false
19
20database:
21 user: "_env:PGUSER:bar"
22 password: "_env:PGPASS:"
23 host: "_env:PGHOST:"
24 port: "_env:PGPORT:"
25 database: "_env:PGDATABASE:bar"
26 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 @@
1argumentPackages@{ ... }:
2
3let
4 defaultPackages = (import <nixpkgs> {}).haskellPackages;
5 haskellPackages = defaultPackages // argumentPackages;
6 pkgs = (import <nixpkgs> {}).pkgs // argumentPackages;
7
8 webshim = with pkgs; stdenv.mkDerivation rec {
9 name = "webshim-${version}";
10 version = "1.16.0";
11 src = fetchFromGitHub {
12 owner = "aFarkas";
13 repo = "webshim";
14 rev = "1.16.0";
15 sha256 = "14pk7hljqipzp0n7vpgcfxr3w4bla57cwyd7bmwmmxrm2zn62cyh";
16 };
17
18 installPhase = ''
19 mkdir -p $out/js
20 cp -r $src/js-webshim/dev/* $out/js/
21 '';
22 };
23in pkgs.stdenv.lib.overrideDerivation (haskellPackages.callPackage ./bar.nix {}) (oldAttrs: {
24 postUnpack = ''
25 rm -rf bar/static/jquery.js bar/static/webshim
26 ln -vs ${pkgs.jquery}/js/jquery.js bar/static
27 ln -vs ${webshim}/js bar/static/webshim
28 '';
29})
diff --git a/shell.nix b/shell.nix
new file mode 100644
index 0000000..b6595aa
--- /dev/null
+++ b/shell.nix
@@ -0,0 +1,18 @@
1{ nixpkgs ? import <nixpkgs> {}, compiler ? "default" }:
2
3let
4 inherit (nixpkgs) pkgs;
5
6 haskellPackages = if compiler == "default"
7 then pkgs.haskellPackages
8 else pkgs.haskell.packages.${compiler};
9
10 drv = haskellPackages.callPackage ./bar.nix {};
11in
12 pkgs.stdenv.lib.overrideDerivation drv.env (oldAttrs: {
13 buildInputs = oldAttrs.buildInputs ++ (with pkgs; [ cabal2nix gup haskellPackages.hlint haskellPackages.stack haskellPackages.yesod-bin ]);
14 shellHook = ''
15 ${oldAttrs.shellHook}
16 export PROMPT_INFO="${oldAttrs.name}"
17 '';
18 })
diff --git a/stack.yaml b/stack.yaml
new file mode 100644
index 0000000..776a6b4
--- /dev/null
+++ b/stack.yaml
@@ -0,0 +1,73 @@
1# This file was automatically generated by 'stack init'
2#
3# Some commonly used options have been documented as comments in this file.
4# For advanced use and comprehensive documentation of the format, please see:
5# http://docs.haskellstack.org/en/stable/yaml_configuration/
6
7# Resolver to choose a 'specific' stackage snapshot or a compiler version.
8# A snapshot resolver dictates the compiler version and the set of packages
9# to be used for project dependencies. For example:
10#
11# resolver: lts-3.5
12# resolver: nightly-2015-09-21
13# resolver: ghc-7.10.2
14# resolver: ghcjs-0.1.0_ghc-7.10.2
15# resolver:
16# name: custom-snapshot
17# location: "./custom-snapshot.yaml"
18resolver: lts-8.5
19
20# User packages to be built.
21# Various formats can be used as shown in the example below.
22#
23# packages:
24# - some-directory
25# - https://example.com/foo/bar/baz-0.0.2.tar.gz
26# - location:
27# git: https://github.com/commercialhaskell/stack.git
28# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
29# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
30# extra-dep: true
31# subdirs:
32# - auto-update
33# - wai
34#
35# A package marked 'extra-dep: true' will only be built if demanded by a
36# non-dependency (i.e. a user package), and its test suites and benchmarks
37# will not be run. This is useful for tweaking upstream packages.
38packages:
39- '.'
40# Dependency packages to be pulled from upstream that are not in the resolver
41# (e.g., acme-missiles-0.3)
42extra-deps: []
43
44# Override default flag values for local packages and extra-deps
45flags: {}
46
47# Extra package databases containing global packages
48extra-package-dbs: []
49
50# Control whether we use the GHC we find on the path
51system-ghc: true
52#
53# Require a specific version of stack, using version ranges
54# require-stack-version: -any # Default
55# require-stack-version: ">=1.3"
56#
57# Override the architecture used by stack, especially useful on Windows
58# arch: i386
59# arch: x86_64
60#
61# Extra directories used by stack for building
62# extra-include-dirs: [/path/to/dir]
63# extra-lib-dirs: [/path/to/dir]
64#
65# Allow a newer minor version of GHC than the snapshot specifies
66# compiler-check: newer-minor
67nix:
68 #enable: true
69 packages:
70 - postgresql
71 - zlib
72 - haskellPackages.yesod-bin
73 - 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 @@
1#!/usr/bin/env zsh
2
3curl -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 @@
1#!/usr/bin/env zsh
2
3mkdir -p ${1}
4
5version="1.16.0"
6curl -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 @@
1$newline never
2$doctype 5
3<html lang="en">
4 <head>
5 <meta charset="UTF-8">
6
7 <title>#{pageTitle pc}
8 <meta name="description" content="">
9 <meta name="author" content="">
10
11 <meta name="viewport" content="width=device-width,initial-scale=1">
12
13 ^{pageHead pc}
14 <body>
15 ^{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 @@
1.table
2 display: table
3.table div
4 vertical-align: middle
5.td
6 display: table-cell
7 text-align: center
8 padding: 0.25em
9.tr
10 display: table-row
11.tc
12 display: table-caption
13 padding: 0.25em
14.th
15 display: table-cell
16 font-variant: small-caps
17 font-weight: bold
18 text-align: center
19 padding: 0.25em
20.kind
21 display: table-cell
22 text-align: left
23 padding: 0.25em
24.table .table .td, .table .table .tc, .table .table .th, .table .table .kind
25 padding: 0
26.error
27 background-color: #fdd
28 text-align: center
29 color: #c00
30 list-style-type: none
31button
32 width: 6em
33 display:inline-text
34.day hr
35 width: 2em
36 border: 1px solid #ddd
37 border-style: solid none solid none
38.sepBelow > div, .sepAbove > div
39 border: 2px none #ddd
40.sepBelow > div
41 border-bottom-style: solid
42.sepAbove > div
43 border-top-style: solid
44.color:nth-child(even)
45 background-color: #f0f0f0
46.color:nth-child(odd)
47 background-color: #fff
48body > div
49 margin: 0 auto
50.table > h1
51 display: table-caption
52nav ul
53 display:block
54 text-align: center
55 li
56 display:inline-block
57 font-variant: small-caps
58 font-size: 1.5em
59 font-weight: bold
60 a
61 text-decoration:none
62 color:#aaa
63 a:hover
64 color:inherit
65 li.active
66 a
67 color:inherit
68 li::before
69 content:" | "
70 color: #ddd
71 li:first-child::before
72 content:""
73label.checkbox
74 input
75 vertical-align: middle
76 span
77 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 @@
1<nav>
2 <ul>
3 $forall MenuItem{..} <- menuItems
4 <li :Just menuItemRoute == mCurrentRoute:.active>
5 <a href=@{menuItemRoute}>#{menuItemLabel}
6
7$if not $ null msgs
8 <ul #messages>
9 $forall (status, msg) <- msgs
10 <li .#{status}>#{msg}
11
12^{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 @@
1webshims.setOptions("forms-ext", {
2 "widgets": {
3 "classes": "hide-dropdownbtn"
4 }
5});
6webshims.activeLang("en-GB");
7webshims.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 @@
1<div .container>
2 <div .row>
3 <div .col-md-2>
4 <div .col-md-8>
5 <h1>#{title}
6 ^{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 @@
1<div .masthead>
2 <div .container>
3 <div .row>
4 <h1 .header>
5 Yesod—a modern framework for blazing fast websites
6 <h2>
7 Fast, stable & spiced with great community
8 <a href="http://www.yesodweb.com/book/" .btn.btn-info.btn-lg>
9 Read the Book
10
11<div .container>
12 <!-- Starting
13 ================================================== -->
14 <div .bs-docs-section>
15 <div .row>
16 <div .col-lg-12>
17 <div .page-header>
18 <h1 #start>Starting
19
20 <p>
21 Now that you have a working project you should use the
22 <a href=http://www.yesodweb.com/book/>Yesod book</a> to learn more.
23 <p>
24 You can also use this scaffolded site to explore some concepts, and best practices.
25
26 <ul .list-group>
27
28 <li .list-group-item>
29 This page was generated by the <tt>#{handlerName}</tt> handler in
30 <tt>Handler/Home.hs</tt>.
31
32 <li .list-group-item>
33 The <tt>#{handlerName}</tt> handler is set to generate your
34 site's home screen in Routes file
35 <tt>config/routes
36
37 <li .list-group-item>
38 We can link to other handlers, like the <a href="@{ProfileR}">Profile</a>.
39 Try it out as an anonymous user and see the access denied.
40 Then, try to <a href="@{AuthR LoginR}">login</a> with the dummy authentication added
41 while in development.
42
43 <li .list-group-item>
44 The HTML you are seeing now is actually composed by a number of <em>widgets</em>, #
45 most of them are brought together by the <tt>defaultLayout</tt> function which #
46 is defined in the <tt>Foundation.hs</tt> module, and used by <tt>#{handlerName}</tt>. #
47 All the files for templates and wigdets are in <tt>templates</tt>.
48
49 <li .list-group-item>
50 A Widget's Html, Css and Javascript are separated in three files with the
51 <tt>.hamlet</tt>, <tt>.lucius</tt> and <tt>.julius</tt> extensions.
52
53 <li .list-group-item ##{aDomId}>
54 If you had javascript enabled then you wouldn't be seeing this.
55
56 <hr>
57
58 <!-- Forms
59 ================================================== -->
60 <div .bs-docs-section>
61 <div .row>
62 <div .col-lg-12>
63 <div .page-header>
64 <h1 #forms>Forms
65
66 <p>
67 This is an example of a form. Read the
68 <a href="http://www.yesodweb.com/book/forms">Forms chapter</a> #
69 on the yesod book to learn more about them.
70
71 <div .row>
72 <div .col-lg-6>
73 <div .bs-callout bs-callout-info well>
74 <form .form-horizontal method=post action=@{HomeR}#forms enctype=#{formEnctype}>
75 ^{formWidget}
76
77 <button .btn.btn-primary type="submit">
78 Upload it!
79
80
81 <div .col-lg-4.col-lg-offset-1>
82 <div .bs-callout.bs-callout-info.upload-response>
83
84 $maybe (FileForm info con) <- submission
85 Your file type is <em>#{fileContentType info}</em>. You say it has: <em>#{con}</em>
86
87 $nothing
88 File upload result will be here...
89
90
91 <hr>
92
93 <!-- JSON
94 ================================================== -->
95 <div .bs-docs-section>
96 <div .row>
97 <div .col-lg-12>
98 <div .page-header>
99 <h1 #json>JSON
100
101 <p>
102 Yesod has JSON support baked-in.
103 The form below makes an AJAX request with Javascript,
104 then updates the page with your submission.
105 (see <tt>Handler/Comment.hs</tt>, <tt>templates/homepage.julius</tt>,
106 and <tt>Handler/Home.hs</tt> for the implementation).
107
108 <div .row>
109 <div .col-lg-6>
110 <div .bs-callout.bs-callout-info.well>
111 <form .form-horizontal ##{commentFormId}>
112 <div .field>
113 <textarea rows="2" ##{commentTextareaId} placeholder="Your comment here..." required></textarea>
114
115 <button .btn.btn-primary type=submit>
116 Create comment
117
118 <div .col-lg-4.col-lg-offset-1>
119 <div .bs-callout.bs-callout-info>
120 <small>
121 Your comments will appear here. You can also open the
122 console log to see the raw response from the server.
123 <ul ##{commentListId}>
124
125 <hr>
126
127 <!-- Testing
128 ================================================== -->
129 <div .bs-docs-section>
130 <div .row>
131 <div .col-lg-12>
132 <div .page-header>
133 <h1 #test>Testing
134
135 <p>
136 And last but not least, Testing. In <tt>test/Spec.hs</tt> you will find a #
137 test suite that performs tests on this page.
138 <p>
139 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 @@
1document.getElementById(#{toJSON aDomId}).innerHTML = "This text was added by the Javascript part of the homepage widget.";
2
3$(function() {
4 $("##{rawJS commentFormId}").submit(function(event) {
5 event.preventDefault();
6
7 var message = $("##{rawJS commentTextareaId}").val();
8 // (Browsers that enforce the "required" attribute on the textarea won't see this alert)
9 if (!message) {
10 alert("Please fill out the comment form first.");
11 return;
12 }
13
14 // Make an AJAX request to the server to create a new comment
15 $.ajax({
16 url: '@{CommentR}',
17 type: 'POST',
18 contentType: "application/json",
19 data: JSON.stringify({
20 message: message,
21 }),
22 success: function (data) {
23 var newNode = $("<li></li>");
24 newNode.text(data.message);
25 console.log(data);
26 $("##{rawJS commentListId}").append(newNode);
27 },
28 error: function (data) {
29 console.log("Error creating comment: " + data);
30 },
31 });
32
33 });
34});
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 @@
1h2##{aDomId} {
2 color: #990
3}
4
5li {
6 line-height: 2em;
7 font-size: 16px
8}
9
10##{commentTextareaId} {
11 width: 400px;
12 height: 100px;
13}
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 @@
1<div .table>
2 <div .tr .sepBelow>
3 <div .th>Description
4 <div .th>Bought
5 <div .th>Expires
6 <div .th>Opened
7 <div .th>Actions
8 $if isJust (preview insertForm =<< formState)
9 $with Just InsertForm{..} <- formState
10 <form .tr .sepBelow action=@{InventoryListingR} method=post enctype=#{fsInsertEncoding}>
11 ^{fsInsertForm}
12 <div .td>
13 <button type=submit>
14 Insert
15 $forall Entity itemId Item{..} <- stock
16 $if Just itemId == (preview updateItem =<< formState)
17 $with Just UpdateForm{..} <- formState
18 <form .tr .color action=@{UpdateItemR fsUpdateItem}##{toPathPiece fsUpdateItem} method=post enctype=#{fsUpdateEncoding} ##{toPathPiece fsUpdateItem}>
19 ^{fsUpdateForm}
20 <div .td>
21 <button type=submit>
22 Save Changes
23 $else
24 <div .tr .color ##{toPathPiece itemId}>
25 <div .kind>#{itemKind}
26 <div .td .day>
27 $maybe bought <- itemBought
28 #{dayFormat bought}
29 $nothing
30 <hr>
31 <div .td .day>
32 $maybe expires <- itemExpires
33 #{dayFormat expires}
34 $nothing
35 <hr>
36 <div .td .day>
37 $maybe opened <- itemOpened
38 #{dayFormat opened}
39 $nothing
40 <form method=post action=@{OpenItemR itemId}>
41 <button type=submit>
42 Open
43 <div .td>
44 <form method=get action=@{UpdateItemR itemId}##{toPathPiece itemId}>
45 <button type=submit>
46 Edit
47 <form method=post action=@{DeleteItemR itemId}>
48 <button type=submit>
49 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 @@
1<div .ui.container>
2
3 <h1>
4 Access granted!
5
6 <p>
7 This page is protected and access is allowed only for authenticated users.
8
9 <p>
10 Your data is protected with us <strong><span class="username">#{userIdent user}</span></strong>!
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-21 23:56:13 +0000