summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorClint Adams <clint@softwarefreedom.org>2012-10-22 15:19:04 -0400
committerClint Adams <clint@softwarefreedom.org>2012-10-22 15:19:04 -0400
commit025eb70c992914fbdf018c189d358ae250d2eeb1 (patch)
tree7367d3726594183bbb908d1a797cacd410c301cc
This needs to be cleaned and sanitized before publication.
-rw-r--r--Application.hs62
-rw-r--r--Auth/Proxied.hs37
-rw-r--r--Foundation.hs181
-rw-r--r--Handler/Home.hs39
-rw-r--r--Handler/User.hs87
-rw-r--r--Import.hs28
-rw-r--r--Model.hs11
-rw-r--r--Settings.hs68
-rw-r--r--Settings/Development.hs14
-rw-r--r--Settings/StaticFiles.hs18
-rw-r--r--config/models19
-rw-r--r--config/routes8
-rw-r--r--config/settings.yml19
-rw-r--r--config/sqlite.yml20
-rw-r--r--devel.hs26
-rw-r--r--dist/build/autogen/Paths_sflctimekeeper.hs32
-rw-r--r--main.hs8
-rw-r--r--sflctimekeeper.cabal118
-rw-r--r--templates/default-layout-wrapper.hamlet47
-rw-r--r--templates/default-layout.hamlet3
-rw-r--r--templates/homepage.hamlet38
-rw-r--r--templates/homepage.julius1
-rw-r--r--templates/homepage.lucius6
-rw-r--r--templates/normalize.lucius439
-rw-r--r--templates/pagenav.hamlet10
-rw-r--r--templates/userpage.hamlet21
-rw-r--r--templates/userpage.lucius2
-rw-r--r--tests/HomeTest.hs24
-rw-r--r--tests/main.hs22
29 files changed, 1408 insertions, 0 deletions
diff --git a/Application.hs b/Application.hs
new file mode 100644
index 0000000..e7d9049
--- /dev/null
+++ b/Application.hs
@@ -0,0 +1,62 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Application
+ ( makeApplication
+ , getApplicationDev
+ , makeFoundation
+ ) where
+
+import Import
+import Settings
+import Yesod.Auth
+import Yesod.Default.Config
+import Yesod.Default.Main
+import Yesod.Default.Handlers
+import Yesod.Logger (Logger, logBS, toProduction)
+import Network.Wai.Middleware.RequestLogger (logCallback, logCallbackDev)
+import qualified Database.Persist.Store
+import Database.Persist.GenericSql (runMigration)
+import Network.HTTP.Conduit (newManager, def)
+
+-- Import all relevant handler modules here.
+-- Don't forget to add new modules to your cabal file!
+import Handler.Home
+import Handler.User
+
+-- This line actually creates our YesodSite 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 creates a WAI application. This is also the
+-- place to put your migrate statements to have automatic database
+-- migrations handled by Yesod.
+makeApplication :: AppConfig DefaultEnv Extra -> Logger -> IO Application
+makeApplication conf logger = do
+ foundation <- makeFoundation conf setLogger
+ app <- toWaiAppPlain foundation
+ return $ logWare app
+ where
+ setLogger = if development then logger else toProduction logger
+ logWare = if development then logCallbackDev (logBS setLogger)
+ else logCallback (logBS setLogger)
+
+makeFoundation :: AppConfig DefaultEnv Extra -> Logger -> IO App
+makeFoundation conf setLogger = do
+ manager <- newManager def
+ s <- staticSite
+ dbconf <- withYamlEnvironment "config/sqlite.yml" (appEnv conf)
+ Database.Persist.Store.loadConfig >>=
+ Database.Persist.Store.applyEnv
+ p <- Database.Persist.Store.createPoolConfig (dbconf :: Settings.PersistConfig)
+ Database.Persist.Store.runPool dbconf (runMigration migrateAll) p
+ return $ App conf setLogger s p manager dbconf
+
+-- for yesod devel
+getApplicationDev :: IO (Int, Application)
+getApplicationDev =
+ defaultDevelApp loader makeApplication
+ where
+ loader = loadConfig (configSettings Development)
+ { csParseExtra = parseExtra
+ }
diff --git a/Auth/Proxied.hs b/Auth/Proxied.hs
new file mode 100644
index 0000000..684a3a1
--- /dev/null
+++ b/Auth/Proxied.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Auth.Proxied
+ ( authProxied
+ ) where
+
+import Yesod.Auth
+import Yesod.Handler (notFound)
+import Text.Hamlet (hamlet)
+import Yesod.Widget (toWidget)
+
+import Yesod.Handler (waiRequest)
+import Data.List (lookup)
+import Data.Maybe (fromMaybe)
+import Network.Wai (Request(requestHeaders))
+import Prelude (($), (.), Bool(..), fmap, either, const, Maybe(..), (/=), (=<<), return, show)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base64 as Base64
+import Data.CaseInsensitive (mk)
+import Data.Text.Encoding (decodeUtf8)
+
+
+authProxied :: YesodAuth m => AuthPlugin m
+authProxied =
+ AuthPlugin "proxied" dispatch login
+ where
+ dispatch _ [] = do
+ mfu <- fmap ((fmap (decodeUtf8 . B.takeWhile (58 /=)) . either (const Nothing) return . Base64.decode . B.drop 1 . B.dropWhile (32 /=) =<<) . lookup (mk "Authorization") . requestHeaders) waiRequest
+ setCreds True $ Creds "proxied" (fromMaybe "" mfu) []
+ dispatch _ _ = notFound
+ login authToMaster =
+ let url = authToMaster (PluginR "proxied" []) in
+ toWidget [hamlet|
+ Your new identifier is: #
+ <a href="@{url}">Zoinkz
+|]
diff --git a/Foundation.hs b/Foundation.hs
new file mode 100644
index 0000000..194fe14
--- /dev/null
+++ b/Foundation.hs
@@ -0,0 +1,181 @@
+module Foundation
+ ( App (..)
+ , Route (..)
+ , AppMessage (..)
+ , resourcesApp
+ , Handler
+ , Widget
+ , Form
+ , maybeAuth
+ , requireAuth
+ , module Settings
+ , module Model
+ ) where
+
+import Prelude
+import Yesod
+import Yesod.Static
+import Yesod.Auth
+import Auth.Proxied (authProxied)
+import Yesod.Default.Config
+import Yesod.Default.Util (addStaticContentExternal)
+import Yesod.Form.Jquery (YesodJquery)
+import Yesod.Logger (Logger, logMsg, formatLogText)
+import Network.HTTP.Conduit (Manager)
+import qualified Settings
+import qualified Database.Persist.Store
+import Settings.StaticFiles
+import Database.Persist.GenericSql
+import Settings (widgetFile, Extra (..))
+import Model
+import Text.Jasmine (minifym)
+import Web.ClientSession (getKey)
+import Text.Hamlet (hamletFile)
+
+-- | The site argument 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
+ { settings :: AppConfig DefaultEnv Extra
+ , getLogger :: Logger
+ , getStatic :: Static -- ^ Settings for static file serving.
+ , connPool :: Database.Persist.Store.PersistConfigPool Settings.PersistConfig -- ^ Database connection pool.
+ , httpManager :: Manager
+ , persistConfig :: Settings.PersistConfig
+ }
+
+-- Set up i18n messages. See the message folder.
+mkMessage "App" "messages" "en"
+
+-- 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/handler
+--
+-- This function does three things:
+--
+-- * Creates the route datatype AppRoute. Every valid URL in your
+-- application can be represented as a value of this type.
+-- * Creates the associated type:
+-- type instance Route App = AppRoute
+-- * Creates the value resourcesApp which contains information on the
+-- resources declared below. This is used in Handler.hs by the call to
+-- mkYesodDispatch
+--
+-- What this function does *not* do is create a YesodSite instance for
+-- App. Creating that instance requires all of the handler functions
+-- for our application to be in scope. However, the handler functions
+-- usually require access to the AppRoute datatype. Therefore, we
+-- split these actions into two functions and place them in separate files.
+mkYesodData "App" $(parseRoutesFile "config/routes")
+
+type Form x = Html -> MForm App App (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
+ approot = ApprootMaster $ appRoot . settings
+
+ -- Store session data on the client in encrypted cookies,
+ -- default session idle timeout is 120 minutes
+ makeSessionBackend _ = do
+ key <- getKey "config/client_session_key.aes"
+ return . Just $ clientSessionBackend key 120
+
+ defaultLayout widget = do
+ master <- getYesod
+ mmsg <- getMessage
+
+ -- 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
+ $(widgetFile "normalize")
+ addStylesheet $ StaticR css_bootstrap_css
+ $(widgetFile "default-layout")
+ hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet")
+
+ -- This is done to provide an optimization for serving static files from
+ -- a separate domain. Please see the staticRoot setting in Settings.hs
+ urlRenderOverride y (StaticR s) =
+ Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s
+ urlRenderOverride _ _ = Nothing
+
+ -- The page to be redirected to when authentication is required.
+ authRoute _ = Just $ AuthR LoginR
+
+ messageLogger y loc level msg =
+ formatLogText (getLogger y) loc level msg >>= logMsg (getLogger y)
+
+ -- 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 = addStaticContentExternal minifym base64md5 Settings.staticDir (StaticR . flip StaticRoute [])
+
+ -- Place Javascript at bottom of the body tag so the rest of the page loads first
+ jsLoader _ = BottomOfBody
+
+ isAuthorized (UserR u) True = isUser u
+ isAuthorized (UserR u) False = isUserOrAdmin u
+ isAuthorized _ _ = return Authorized
+
+isUser :: UserId -> GHandler s App AuthResult
+isUser t = do
+ ma <- maybeAuth
+ return $ case ma of
+ Nothing -> AuthenticationRequired
+ Just (Entity u _) -> if t == u then Authorized else Unauthorized "That ain't your page."
+
+isUserOrAdmin :: UserId -> GHandler s App AuthResult
+isUserOrAdmin t = do
+ ma <- maybeAuth
+ return $ case ma of
+ Nothing -> AuthenticationRequired
+ Just (Entity u v) -> if t == u || userIsAdmin v then Authorized else Unauthorized "You must be an admin"
+
+-- How to run database actions.
+instance YesodPersist App where
+ type YesodPersistBackend App = SqlPersist
+ runDB f = do
+ master <- getYesod
+ Database.Persist.Store.runPool
+ (persistConfig master)
+ f
+ (connPool master)
+
+instance YesodAuth App where
+ type AuthId App = UserId
+
+ -- Where to send a user after successful login
+ loginDest _ = HomeR
+ -- Where to send a user after logout
+ logoutDest _ = HomeR
+
+ getAuthId creds = runDB $ do
+ x <- getBy $ UniqueUser $ credsIdent creds
+ case x of
+ Just (Entity uid _) -> return $ Just uid
+ Nothing -> if credsIdent creds == "" then return Nothing
+ else fmap Just $ insert $ User (credsIdent creds) False
+
+ authPlugins _ = [authProxied]
+
+ authHttpManager = httpManager
+
+-- 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
+
+-- Note: previous versions of the scaffolding included a deliver function to
+-- send emails. Unfortunately, there are too many different options for us to
+-- give a reasonable default. Instead, the information is available on the
+-- wiki:
+--
+-- https://github.com/yesodweb/yesod/wiki/Sending-email
+
+instance YesodJquery App -- FIXME: go static
diff --git a/Handler/Home.hs b/Handler/Home.hs
new file mode 100644
index 0000000..3444a5b
--- /dev/null
+++ b/Handler/Home.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE TupleSections, OverloadedStrings #-}
+module Handler.Home where
+
+import Import
+
+-- This is a handler function for the GET request method on the HomeR
+-- resource pattern. All of your resource patterns are defined in
+-- config/routes
+--
+-- The majority of the code you will write in Yesod lives in these handler
+-- functions. You can spread them across multiple files if you are so
+-- inclined, or create a single monolithic file.
+getHomeR :: Handler RepHtml
+getHomeR = do
+ (formWidget, formEnctype) <- generateFormPost sampleForm
+ let submission = Nothing :: Maybe (FileInfo, Text)
+ handlerName = "getHomeR" :: Text
+ defaultLayout $ do
+ aDomId <- lift newIdent
+ setTitle "Welcome To Yesod!"
+ $(widgetFile "homepage")
+
+postHomeR :: Handler RepHtml
+postHomeR = do
+ ((result, formWidget), formEnctype) <- runFormPost sampleForm
+ let handlerName = "postHomeR" :: Text
+ submission = case result of
+ FormSuccess res -> Just res
+ _ -> Nothing
+
+ defaultLayout $ do
+ aDomId <- lift newIdent
+ setTitle "Welcome To Yesod!"
+ $(widgetFile "homepage")
+
+sampleForm :: Form (FileInfo, Text)
+sampleForm = renderDivs $ (,)
+ <$> fileAFormReq "Choose a file"
+ <*> areq textField "What's on the file?" Nothing
diff --git a/Handler/User.hs b/Handler/User.hs
new file mode 100644
index 0000000..499ba20
--- /dev/null
+++ b/Handler/User.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE TupleSections, OverloadedStrings #-}
+module Handler.User where
+
+import Import
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+import Data.Text.Read (decimal)
+import Data.Time.Clock (getCurrentTime, UTCTime, utctDay)
+import Yesod.Form.Jquery (jqueryDayField, def)
+
+getUserR :: UserId -> Handler RepHtml
+getUserR cid = do
+ user <- runDB $ get404 cid
+ ma <- maybeAuth
+ let username = userIdent user
+ let isUser = Just user == fmap entityVal ma
+ (pageNumber, pages) <- pagePosition cid
+ let doPrev = pageNumber > 1
+ let doNext = pageNumber < pages
+ let prevPageNumber = pageNumber - 1
+ let nextPageNumber = pageNumber + 1
+ let pageNavWidget = $(widgetFile "pagenav")
+ entries <- runDB $ getEntriesForPage cid pageNumber
+ cats' <- runDB $ selectList [TimeCategoryDisabled ==. False] []
+ let cats = map (\x -> ((timeCategoryName . entityVal) x, entityKey x)) cats'
+ (formWidget, formEnctype) <- generateFormPost (timeEntryForm cid cats)
+ defaultLayout $ do
+ aDomId <- lift newIdent
+ (setTitle . toHtml) ("Time entries for " `T.append` username)
+ $(widgetFile "userpage")
+
+postUserR :: UserId -> Handler RepHtml
+postUserR cid = do
+ user <- runDB $ get404 cid
+ ma <- maybeAuth
+ let username = userIdent user
+ let isUser = Just user == fmap entityVal ma
+ (pageNumber, pages) <- pagePosition cid
+ let doPrev = pageNumber > 1
+ let doNext = pageNumber < pages
+ let prevPageNumber = pageNumber - 1
+ let nextPageNumber = pageNumber + 1
+ let pageNavWidget = $(widgetFile "pagenav")
+ cats' <- runDB $ selectList [TimeCategoryDisabled ==. False] []
+ let cats = map (\x -> ((timeCategoryName . entityVal) x, entityKey x)) cats'
+ ((result, formWidget), formEnctype) <- runFormPost (timeEntryForm cid cats)
+ _ <- case result of
+ FormSuccess res -> (runDB $ insert res) >> return ()
+ _ -> return ()
+ entries <- runDB $ getEntriesForPage cid pageNumber
+
+ defaultLayout $ do
+ aDomId <- lift newIdent
+ (setTitle . toHtml) ("Entry submitted for " `T.append` username)
+ $(widgetFile "userpage")
+
+timeEntryAForm :: UTCTime -> [(Text,TimeCategoryId)] -> UserId -> AForm App App TimeEntry
+timeEntryAForm ct cats uid = TimeEntry
+ <$> pure uid
+ <*> areq (selectFieldList cats) "category" Nothing
+ <*> areq (jqueryDayField def) "day" (Just (utctDay ct))
+ <*> areq doubleField "hours" Nothing
+ <*> pure ct
+
+timeEntryForm :: UserId -> [(Text,TimeCategoryId)] -> Html -> MForm App App (FormResult TimeEntry, Widget)
+timeEntryForm u c h = do
+ ct <- liftIO getCurrentTime
+ renderDivs (timeEntryAForm ct c u) h
+
+getEntriesForPage :: UserId -> Int -> YesodDB App App [(Text, Text, Text)]
+getEntriesForPage uid pageNumber = do
+ entries <- selectList [TimeEntryUser ==. uid] [Desc TimeEntryTimestamp, LimitTo 25, OffsetBy ((pageNumber - 1) * 25)]
+ mapM (\(Entity _ e) -> cat (timeEntryCategory e) >>= \x -> return (x, hours e, day e)) entries
+ where
+ cat :: TimeCategoryId -> YesodDB App App Text
+ cat y = do x <- getJust y
+ return $ timeCategoryName x
+ day :: TimeEntry -> Text
+ day = T.pack . show . timeEntryDay
+ hours :: TimeEntry -> Text
+ hours = T.pack . show . timeEntryHours
+
+pagePosition :: UserId -> GHandler App App (Int, Int)
+pagePosition uid = do
+ pageNumber <- fmap (either (const 1) id . fmap fst . fromMaybe (Right (1,"")) . fmap decimal) (lookupGetParam "page")
+ cnt <- runDB $ count [TimeEntryUser ==. uid]
+ return (pageNumber, ((cnt - 1) `div` 25) + 1)
diff --git a/Import.hs b/Import.hs
new file mode 100644
index 0000000..641de38
--- /dev/null
+++ b/Import.hs
@@ -0,0 +1,28 @@
+module Import
+ ( module Prelude
+ , module Yesod
+ , module Foundation
+ , module Settings.StaticFiles
+ , module Settings.Development
+ , module Data.Monoid
+ , module Control.Applicative
+ , Text
+#if __GLASGOW_HASKELL__ < 704
+ , (<>)
+#endif
+ ) where
+
+import Prelude hiding (writeFile, readFile, head, tail, init, last)
+import Yesod hiding (Route(..))
+import Foundation
+import Data.Monoid (Monoid (mappend, mempty, mconcat))
+import Control.Applicative ((<$>), (<*>), pure)
+import Data.Text (Text)
+import Settings.StaticFiles
+import Settings.Development
+
+#if __GLASGOW_HASKELL__ < 704
+infixr 5 <>
+(<>) :: Monoid m => m -> m -> m
+(<>) = mappend
+#endif
diff --git a/Model.hs b/Model.hs
new file mode 100644
index 0000000..2738892
--- /dev/null
+++ b/Model.hs
@@ -0,0 +1,11 @@
+module Model where
+
+import Prelude
+import Yesod
+import Data.Text (Text)
+import Database.Persist.Quasi
+import Data.Time.Calendar (Day)
+import Data.Time.Clock (UTCTime)
+
+share [mkPersist sqlSettings, mkMigrate "migrateAll"]
+ $(persistFileWith lowerCaseSettings "config/models")
diff --git a/Settings.hs b/Settings.hs
new file mode 100644
index 0000000..f9f7075
--- /dev/null
+++ b/Settings.hs
@@ -0,0 +1,68 @@
+-- | 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
+ ( widgetFile
+ , PersistConfig
+ , staticRoot
+ , staticDir
+ , Extra (..)
+ , parseExtra
+ ) where
+
+import Prelude
+import Text.Shakespeare.Text (st)
+import Language.Haskell.TH.Syntax
+import Database.Persist.Sqlite (SqliteConf)
+import Yesod.Default.Config
+import qualified Yesod.Default.Util
+import Data.Text (Text)
+import Data.Yaml
+import Control.Applicative
+import Settings.Development
+
+-- | Which Persistent backend this site is using.
+type PersistConfig = SqliteConf
+
+-- Static setting below. Changing these requires a recompile
+
+-- | The location of static files on your system. This is a file system
+-- path. The default value works properly with your scaffolded site.
+staticDir :: FilePath
+staticDir = "static"
+
+-- | The base URL for your static files. As you can see by the default
+-- value, this can simply be "static" appended to your application root.
+-- A powerful optimization can be serving static files from a separate
+-- domain name. This allows you to use a web server optimized for static
+-- files, more easily set expires and cache values, and avoid possibly
+-- costly transference of cookies on static files. For more information,
+-- please see:
+-- http://code.google.com/speed/page-speed/docs/request.html#ServeFromCookielessDomain
+--
+-- If you change the resource pattern for StaticR in Foundation.hs, you will
+-- have to make a corresponding change here.
+--
+-- To see how this value is used, see urlRenderOverride in Foundation.hs
+staticRoot :: AppConfig DefaultEnv x -> Text
+staticRoot conf = [st|#{appRoot conf}/static|]
+
+
+-- The rest of this file contains settings which rarely need changing by a
+-- user.
+
+widgetFile :: String -> Q Exp
+widgetFile = if development then Yesod.Default.Util.widgetFileReload
+ else Yesod.Default.Util.widgetFileNoReload
+
+data Extra = Extra
+ { extraCopyright :: Text
+ , extraAnalytics :: Maybe Text -- ^ Google Analytics
+ } deriving Show
+
+parseExtra :: DefaultEnv -> Object -> Parser Extra
+parseExtra _ o = Extra
+ <$> o .: "copyright"
+ <*> o .:? "analytics"
diff --git a/Settings/Development.hs b/Settings/Development.hs
new file mode 100644
index 0000000..73613f0
--- /dev/null
+++ b/Settings/Development.hs
@@ -0,0 +1,14 @@
+module Settings.Development where
+
+import Prelude
+
+development :: Bool
+development =
+#if DEVELOPMENT
+ True
+#else
+ False
+#endif
+
+production :: Bool
+production = not development
diff --git a/Settings/StaticFiles.hs b/Settings/StaticFiles.hs
new file mode 100644
index 0000000..2510795
--- /dev/null
+++ b/Settings/StaticFiles.hs
@@ -0,0 +1,18 @@
+module Settings.StaticFiles where
+
+import Prelude (IO)
+import Yesod.Static
+import qualified Yesod.Static as Static
+import Settings (staticDir)
+import Settings.Development
+
+-- | use this to create your static file serving site
+staticSite :: IO Static.Static
+staticSite = if development then Static.staticDevel staticDir
+ else Static.static staticDir
+
+-- | This generates easy references to files in the static directory at compile time,
+-- giving you compile-time verification that referenced files exist.
+-- Warning: any files added to your static directory during run-time can't be
+-- accessed this way. You'll have to use their FilePath or URL to access them.
+$(staticFiles Settings.staticDir)
diff --git a/config/models b/config/models
new file mode 100644
index 0000000..172af23
--- /dev/null
+++ b/config/models
@@ -0,0 +1,19 @@
+User
+ ident Text
+ isAdmin Bool default=False
+ UniqueUser ident
+ deriving Show Eq
+TimeEntry
+ user UserId
+ category TimeCategoryId
+ day Day
+ hours Double
+ timestamp UTCTime
+ deriving Show Eq
+TimeCategory
+ name Text
+ disabled Bool
+ UniqueTimeCategory name
+ deriving Show Eq
+
+ -- By default this file is used in Model.hs (which is imported by Foundation.hs)
diff --git a/config/routes b/config/routes
new file mode 100644
index 0000000..a83a59f
--- /dev/null
+++ b/config/routes
@@ -0,0 +1,8 @@
+/static StaticR Static getStatic
+/auth AuthR Auth getAuth
+
+/favicon.ico FaviconR GET
+/robots.txt RobotsR GET
+
+/ HomeR GET POST
+/user/#UserId UserR GET POST
diff --git a/config/settings.yml b/config/settings.yml
new file mode 100644
index 0000000..70828ae
--- /dev/null
+++ b/config/settings.yml
@@ -0,0 +1,19 @@
+Default: &defaults
+ host: "*4" # any IPv4 host
+ port: 3000
+ approot: "http://burrell.hq.sflc.info:80"
+ copyright: Copyright (C) 2012 Clint Adams
+ #analytics: UA-YOURCODE
+
+Development:
+ <<: *defaults
+
+Testing:
+ <<: *defaults
+
+Staging:
+ <<: *defaults
+
+Production:
+ #approot: "http://www.example.com"
+ <<: *defaults
diff --git a/config/sqlite.yml b/config/sqlite.yml
new file mode 100644
index 0000000..ba8db2e
--- /dev/null
+++ b/config/sqlite.yml
@@ -0,0 +1,20 @@
+Default: &defaults
+ database: sflctimekeeper.sqlite3
+ poolsize: 10
+
+Development:
+ <<: *defaults
+
+Testing:
+ database: sflctimekeeper_test.sqlite3
+ <<: *defaults
+
+Staging:
+ database: sflctimekeeper_staging.sqlite3
+ poolsize: 100
+ <<: *defaults
+
+Production:
+ database: sflctimekeeper_production.sqlite3
+ poolsize: 100
+ <<: *defaults
diff --git a/devel.hs b/devel.hs
new file mode 100644
index 0000000..0181215
--- /dev/null
+++ b/devel.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE PackageImports #-}
+import "sflctimekeeper" Application (getApplicationDev)
+import Network.Wai.Handler.Warp
+ (runSettings, defaultSettings, settingsPort)
+import Control.Concurrent (forkIO)
+import System.Directory (doesFileExist, removeFile)
+import System.Exit (exitSuccess)
+import Control.Concurrent (threadDelay)
+
+main :: IO ()
+main = do
+ putStrLn "Starting devel application"
+ (port, app) <- getApplicationDev
+ forkIO $ runSettings defaultSettings
+ { settingsPort = port
+ } app
+ loop
+
+loop :: IO ()
+loop = do
+ threadDelay 100000
+ e <- doesFileExist "dist/devel-terminate"
+ if e then terminateDevel else loop
+
+terminateDevel :: IO ()
+terminateDevel = exitSuccess
diff --git a/dist/build/autogen/Paths_sflctimekeeper.hs b/dist/build/autogen/Paths_sflctimekeeper.hs
new file mode 100644
index 0000000..76e952e
--- /dev/null
+++ b/dist/build/autogen/Paths_sflctimekeeper.hs
@@ -0,0 +1,32 @@
+module Paths_sflctimekeeper (
+ version,
+ getBinDir, getLibDir, getDataDir, getLibexecDir,
+ getDataFileName
+ ) where
+
+import qualified Control.Exception as Exception
+import Data.Version (Version(..))
+import System.Environment (getEnv)
+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
+catchIO = Exception.catch
+
+
+version :: Version
+version = Version {versionBranch = [0,0,0], versionTags = []}
+bindir, libdir, datadir, libexecdir :: FilePath
+
+bindir = "/home/clint/.cabal/bin"
+libdir = "/home/clint/.cabal/lib/sflctimekeeper-0.0.0/ghc-7.4.1"
+datadir = "/home/clint/.cabal/share/sflctimekeeper-0.0.0"
+libexecdir = "/home/clint/.cabal/libexec"
+
+getBinDir, getLibDir, getDataDir, getLibexecDir :: IO FilePath
+getBinDir = catchIO (getEnv "sflctimekeeper_bindir") (\_ -> return bindir)
+getLibDir = catchIO (getEnv "sflctimekeeper_libdir") (\_ -> return libdir)
+getDataDir = catchIO (getEnv "sflctimekeeper_datadir") (\_ -> return datadir)
+getLibexecDir = catchIO (getEnv "sflctimekeeper_libexecdir") (\_ -> return libexecdir)
+
+getDataFileName :: FilePath -> IO FilePath
+getDataFileName name = do
+ dir <- getDataDir
+ return (dir ++ "/" ++ name)
diff --git a/main.hs b/main.hs
new file mode 100644
index 0000000..a059fcb
--- /dev/null
+++ b/main.hs
@@ -0,0 +1,8 @@
+import Prelude (IO)
+import Yesod.Default.Config (fromArgs)
+import Yesod.Default.Main (defaultMain)
+import Settings (parseExtra)
+import Application (makeApplication)
+
+main :: IO ()
+main = defaultMain (fromArgs parseExtra) makeApplication
diff --git a/sflctimekeeper.cabal b/sflctimekeeper.cabal
new file mode 100644
index 0000000..1548421
--- /dev/null
+++ b/sflctimekeeper.cabal
@@ -0,0 +1,118 @@
+name: sflctimekeeper
+version: 0.0.0
+license: OtherLicense
+license-file: LICENSE
+author: Clint Adams
+maintainer: Clint Adams
+synopsis: The greatest Yesod web application ever.
+description: I'm sure you can say something clever here if you try.
+category: Web
+stability: Experimental
+cabal-version: >= 1.8
+build-type: Simple
+homepage: http://sflctimekeeper.yesodweb.com/
+
+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
+ exposed-modules: Application
+ Foundation
+ Import
+ Model
+ Settings
+ Settings.StaticFiles
+ Settings.Development
+ Handler.Home
+ Handler.User
+ Auth.Proxied
+
+ if flag(dev) || flag(library-only)
+ cpp-options: -DDEVELOPMENT
+ ghc-options: -Wall -threaded -O0
+ else
+ ghc-options: -Wall -threaded -O2
+
+ extensions: TemplateHaskell
+ QuasiQuotes
+ OverloadedStrings
+ NoImplicitPrelude
+ CPP
+ MultiParamTypeClasses
+ TypeFamilies
+ GADTs
+ GeneralizedNewtypeDeriving
+ FlexibleContexts
+ EmptyDataDecls
+ NoMonomorphismRestriction
+
+ build-depends: base >= 4 && < 5
+ , yesod >= 1.0 && < 1.1
+ , yesod-core >= 1.0 && < 1.1
+ , yesod-auth >= 1.0 && < 1.1
+ , yesod-static >= 1.0 && < 1.1
+ , yesod-default >= 1.0 && < 1.1
+ , yesod-form >= 1.0 && < 1.1
+ , yesod-test >= 0.2 && < 0.3
+ , clientsession >= 0.7.3 && < 0.8
+ , bytestring >= 0.9 && < 0.10
+ , text >= 0.11 && < 0.12
+ , persistent >= 0.9 && < 0.10
+ , persistent-sqlite >= 0.9 && < 0.10
+ , template-haskell
+ , hamlet >= 1.0 && < 1.1
+ , shakespeare-css >= 1.0 && < 1.1
+ , shakespeare-js >= 1.0 && < 1.1
+ , shakespeare-text >= 1.0 && < 1.1
+ , hjsmin >= 0.1 && < 0.2
+ , monad-control >= 0.3 && < 0.4
+ , wai-extra >= 1.2 && < 1.3
+ , yaml >= 0.7 && < 0.8
+ , http-conduit >= 1.4 && < 1.5
+ , directory >= 1.1 && < 1.2
+ , warp >= 1.2 && < 1.3
+ , time
+ , wai
+ , case-insensitive
+ , http-types
+ , base64-bytestring
+
+executable sflctimekeeper
+ if flag(library-only)
+ Buildable: False
+
+ main-is: ../main.hs
+ hs-source-dirs: dist
+ build-depends: base
+ , sflctimekeeper
+ , yesod-default
+ , time
+
+test-suite test
+ type: exitcode-stdio-1.0
+ main-is: main.hs
+ hs-source-dirs: tests
+ ghc-options: -Wall
+ extensions: TemplateHaskell
+ QuasiQuotes
+ OverloadedStrings
+ NoImplicitPrelude
+ CPP
+ OverloadedStrings
+ MultiParamTypeClasses
+ TypeFamilies
+ GADTs
+ GeneralizedNewtypeDeriving
+ FlexibleContexts
+
+ build-depends: base
+ , sflctimekeeper
+ , yesod-test
+ , yesod-default
+ , yesod-core
+ , time
diff --git a/templates/default-layout-wrapper.hamlet b/templates/default-layout-wrapper.hamlet
new file mode 100644
index 0000000..37a22d9
--- /dev/null
+++ b/templates/default-layout-wrapper.hamlet
@@ -0,0 +1,47 @@
+\<!doctype html>
+\<!--[if lt IE 7]> <html class="no-js ie6 oldie" lang="en"> <![endif]-->
+\<!--[if IE 7]> <html class="no-js ie7 oldie" lang="en"> <![endif]-->
+\<!--[if IE 8]> <html class="no-js ie8 oldie" lang="en"> <![endif]-->
+\<!--[if gt IE 8]><!-->
+<html class="no-js" lang="en"> <!--<![endif]-->
+ <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}
+
+ \<!--[if lt IE 9]>
+ \<script src="http://html5shiv.googlecode.com/svn/trunk/html5.js"></script>
+ \<![endif]-->
+
+ <script>
+ document.documentElement.className = document.documentElement.className.replace(/\bno-js\b/,'js');
+ <body>
+ <div class="container">
+ <header>
+ <div id="main" role="main">
+ ^{pageBody pc}
+ <footer>
+ #{extraCopyright $ appExtra $ settings master}
+
+ $maybe analytics <- extraAnalytics $ appExtra $ settings master
+ <script>
+ if(!window.location.href.match(/localhost/)){
+ window._gaq = [['_setAccount','#{analytics}'],['_trackPageview'],['_trackPageLoadTime']];
+ (function() {
+ \ var ga = document.createElement('script'); ga.type = 'text/javascript'; ga.async = true;
+ \ ga.src = ('https:' == document.location.protocol ? 'https://ssl' : 'http://www') + '.google-analytics.com/ga.js';
+ \ var s = document.getElementsByTagName('script')[0]; s.parentNode.insertBefore(ga, s);
+ })();
+ }
+ \<!-- Prompt IE 6 users to install Chrome Frame. Remove this if you want to support IE 6. chromium.org/developers/how-tos/chrome-frame-getting-started -->
+ \<!--[if lt IE 7 ]>
+ <script src="//ajax.googleapis.com/ajax/libs/chrome-frame/1.0.3/CFInstall.min.js">
+ <script>
+ window.attachEvent('onload',function(){CFInstall.check({mode:'overlay'})})
+ \<![endif]-->
diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet
new file mode 100644
index 0000000..fa86744
--- /dev/null
+++ b/templates/default-layout.hamlet
@@ -0,0 +1,3 @@
+$maybe msg <- mmsg
+ <div #message>#{msg}
+^{widget}
diff --git a/templates/homepage.hamlet b/templates/homepage.hamlet
new file mode 100644
index 0000000..c40be5c
--- /dev/null
+++ b/templates/homepage.hamlet
@@ -0,0 +1,38 @@
+<h1>_{MsgHello}
+
+<ol>
+ <li>Now that you have a working project you should use the #
+ \<a href="http://www.yesodweb.com/book/">Yesod book</a> to learn more. #
+ You can also use this scaffolded site to explore some basic concepts.
+
+ <li> This page was generated by the #{handlerName} handler in #
+ \<em>Handler/Root.hs</em>.
+
+ <li> The #{handlerName} handler is set to generate your site's home screen in Routes file #
+ <em>config/routes
+
+ <li> The HTML you are seeing now is actually composed by a number of <em>widgets</em>, #
+ most of them are brought together by the <em>defaultLayout</em> function which #
+ is defined in the <em>Foundation.hs</em> module, and used by <em>#{handlerName}</em>. #
+ All the files for templates and wigdets are in <em>templates</em>.
+
+ <li>
+ A Widget's Html, Css and Javascript are separated in three files with the #
+ \<em>.hamlet</em>, <em>.lucius</em> and <em>.julius</em> extensions.
+
+ <li ##{aDomId}>If you had javascript enabled then you wouldn't be seeing this.
+
+ <li #form>
+ This is an example trivial Form. Read the #
+ \<a href="http://www.yesodweb.com/book/forms">Forms chapter</a> #
+ on the yesod book to learn more about them.
+ $maybe (info,con) <- submission
+ <div .message>
+ Your file's type was <em>#{fileContentType info}</em>. You say it has: <em>#{con}</em>
+ <form method=post action=@{HomeR}#form enctype=#{formEnctype}>
+ ^{formWidget}
+ <input type="submit" value="Send it!">
+
+ <li> And last but not least, Testing. In <em>tests/main.hs</em> you will find a #
+ test suite that performs tests on this page. #
+ You can run your tests by doing: <pre>yesod test</pre>
diff --git a/templates/homepage.julius b/templates/homepage.julius
new file mode 100644
index 0000000..efae799
--- /dev/null
+++ b/templates/homepage.julius
@@ -0,0 +1 @@
+document.getElementById("#{aDomId}").innerHTML = "This text was added by the Javascript part of the homepage widget.";
diff --git a/templates/homepage.lucius b/templates/homepage.lucius
new file mode 100644
index 0000000..54986f8
--- /dev/null
+++ b/templates/homepage.lucius
@@ -0,0 +1,6 @@
+h1 {
+ text-align: center
+}
+h2##{aDomId} {
+ color: #990
+}
diff --git a/templates/normalize.lucius b/templates/normalize.lucius
new file mode 100644
index 0000000..9fc7ae4
--- /dev/null
+++ b/templates/normalize.lucius
@@ -0,0 +1,439 @@
+/*! normalize.css 2011-08-12T17:28 UTC ยท http://github.com/necolas/normalize.css */
+
+/* =============================================================================
+ HTML5 display definitions
+ ========================================================================== */
+
+/*
+ * Corrects block display not defined in IE6/7/8/9 & FF3
+ */
+
+article,
+aside,
+details,
+figcaption,
+figure,
+footer,
+header,
+hgroup,
+nav,
+section {
+ display: block;
+}
+
+/*
+ * Corrects inline-block display not defined in IE6/7/8/9 & FF3
+ */
+
+audio,
+canvas,
+video {
+ display: inline-block;
+ *display: inline;
+ *zoom: 1;
+}
+
+/*
+ * Prevents modern browsers from displaying 'audio' without controls
+ */
+
+audio:not([controls]) {
+ display: none;
+}
+
+/*
+ * Addresses styling for 'hidden' attribute not present in IE7/8/9, FF3, S4
+ * Known issue: no IE6 support
+ */
+
+[hidden] {
+ display: none;
+}
+
+
+/* =============================================================================
+ Base
+ ========================================================================== */
+
+/*
+ * 1. Corrects text resizing oddly in IE6/7 when body font-size is set using em units
+ * http://clagnut.com/blog/348/#c790
+ * 2. Keeps page centred in all browsers regardless of content height
+ * 3. Prevents iOS text size adjust after orientation change, without disabling user zoom
+ * www.456bereastreet.com/archive/201012/controlling_text_size_in_safari_for_ios_without_disabling_user_zoom/
+ */
+
+html {
+ font-size: 100%; /* 1 */
+ overflow-y: scroll; /* 2 */
+ -webkit-text-size-adjust: 100%; /* 3 */
+ -ms-text-size-adjust: 100%; /* 3 */
+}
+
+/*
+ * Addresses margins handled incorrectly in IE6/7
+ */
+
+body {
+ margin: 0;
+}
+
+/*
+ * Addresses font-family inconsistency between 'textarea' and other form elements.
+ */
+
+body,
+button,
+input,
+select,
+textarea {
+ font-family: sans-serif;
+}
+
+
+/* =============================================================================
+ Links
+ ========================================================================== */
+
+a {
+ color: #00e;
+}
+
+a:visited {
+ color: #551a8b;
+}
+
+/*
+ * Addresses outline displayed oddly in Chrome
+ */
+
+a:focus {
+ outline: thin dotted;
+}
+
+/*
+ * Improves readability when focused and also mouse hovered in all browsers
+ * people.opera.com/patrickl/experiments/keyboard/test
+ */
+
+a:hover,
+a:active {
+ outline: 0;
+}
+
+
+/* =============================================================================
+ Typography
+ ========================================================================== */
+
+/*
+ * Addresses styling not present in IE7/8/9, S5, Chrome
+ */
+
+abbr[title] {
+ border-bottom: 1px dotted;
+}
+
+/*
+ * Addresses style set to 'bolder' in FF3/4, S4/5, Chrome
+*/
+
+b,
+strong {
+ font-weight: bold;
+}
+
+blockquote {
+ margin: 1em 40px;
+}
+
+/*
+ * Addresses styling not present in S5, Chrome
+ */
+
+dfn {
+ font-style: italic;
+}
+
+/*
+ * Addresses styling not present in IE6/7/8/9
+ */
+
+mark {
+ background: #ff0;
+ color: #000;
+}
+
+/*
+ * Corrects font family set oddly in IE6, S4/5, Chrome
+ * en.wikipedia.org/wiki/User:Davidgothberg/Test59
+ */
+
+pre,
+code,
+kbd,
+samp {
+ font-family: monospace, serif;
+ _font-family: 'courier new', monospace;
+ font-size: 1em;
+}
+
+/*
+ * Improves readability of pre-formatted text in all browsers
+ */
+
+pre {
+ white-space: pre;
+ white-space: pre-wrap;
+ word-wrap: break-word;
+}
+
+/*
+ * 1. Addresses CSS quotes not supported in IE6/7
+ * 2. Addresses quote property not supported in S4
+ */
+
+/* 1 */
+
+q {
+ quotes: none;
+}
+
+/* 2 */
+
+q:before,
+q:after {
+ content: '';
+ content: none;
+}
+
+small {
+ font-size: 75%;
+}
+
+/*
+ * Prevents sub and sup affecting line-height in all browsers
+ * gist.github.com/413930
+ */
+
+sub,
+sup {
+ font-size: 75%;
+ line-height: 0;
+ position: relative;
+ vertical-align: baseline;
+}
+
+sup {
+ top: -0.5em;
+}
+
+sub {
+ bottom: -0.25em;
+}
+
+
+/* =============================================================================
+ Lists
+ ========================================================================== */
+
+ul,
+ol {
+ margin: 1em 0;
+ padding: 0 0 0 40px;
+}
+
+dd {
+ margin: 0 0 0 40px;
+}
+
+nav ul,
+nav ol {
+ list-style: none;
+ list-style-image: none;
+}
+
+
+/* =============================================================================
+ Embedded content
+ ========================================================================== */
+
+/*
+ * 1. Removes border when inside 'a' element in IE6/7/8/9
+ * 2. Improves image quality when scaled in IE7
+ * code.flickr.com/blog/2008/11/12/on-ui-quality-the-little-things-client-side-image-resizing/
+ */
+
+img {
+ border: 0; /* 1 */
+ -ms-interpolation-mode: bicubic; /* 2 */
+}
+
+/*
+ * Corrects overflow displayed oddly in IE9
+ */
+
+svg:not(:root) {
+ overflow: hidden;
+}
+
+
+/* =============================================================================
+ Figures
+ ========================================================================== */
+
+/*
+ * Addresses margin not present in IE6/7/8/9, S5, O11
+ */
+
+figure {
+ margin: 0;
+}
+
+
+/* =============================================================================
+ Forms
+ ========================================================================== */
+
+/*
+ * Corrects margin displayed oddly in IE6/7
+ */
+
+form {
+ margin: 0;
+}
+
+/*
+ * Define consistent margin and padding
+ */
+
+fieldset {
+ margin: 0 2px;
+ padding: 0.35em 0.625em 0.75em;
+}
+
+/*
+ * 1. Corrects color not being inherited in IE6/7/8/9
+ * 2. Corrects alignment displayed oddly in IE6/7
+ */
+
+legend {
+ border: 0; /* 1 */
+ *margin-left: -7px; /* 2 */
+}
+
+/*
+ * 1. Corrects font size not being inherited in all browsers
+ * 2. Addresses margins set differently in IE6/7, F3/4, S5, Chrome
+ * 3. Improves appearance and consistency in all browsers
+ */
+
+button,
+input,
+select,
+textarea {
+ font-size: 100%; /* 1 */
+ margin: 0; /* 2 */
+ vertical-align: baseline; /* 3 */
+ *vertical-align: middle; /* 3 */
+}
+
+/*
+ * 1. Addresses FF3/4 setting line-height using !important in the UA stylesheet
+ * 2. Corrects inner spacing displayed oddly in IE6/7
+ */
+
+button,
+input {
+ line-height: normal; /* 1 */
+ *overflow: visible; /* 2 */
+}
+
+/*
+ * Corrects overlap and whitespace issue for buttons and inputs in IE6/7
+ * Known issue: reintroduces inner spacing
+ */
+
+table button,
+table input {
+ *overflow: auto;
+}
+
+/*
+ * 1. Improves usability and consistency of cursor style between image-type 'input' and others
+ * 2. Corrects inability to style clickable 'input' types in iOS
+ */
+
+button,
+html input[type="button"],
+input[type="reset"],
+input[type="submit"] {
+ cursor: pointer; /* 1 */
+ -webkit-appearance: button; /* 2 */
+}
+
+/*
+ * 1. Addresses box sizing set to content-box in IE8/9
+ * 2. Addresses excess padding in IE8/9
+ */
+
+input[type="checkbox"],
+input[type="radio"] {
+ box-sizing: border-box; /* 1 */
+ padding: 0; /* 2 */
+}
+
+/*
+ * 1. Addresses appearance set to searchfield in S5, Chrome
+ * 2. Addresses box sizing set to border-box in S5, Chrome (include -moz to future-proof)
+ */
+
+input[type="search"] {
+ -webkit-appearance: textfield; /* 1 */
+ -moz-box-sizing: content-box;
+ -webkit-box-sizing: content-box; /* 2 */
+ box-sizing: content-box;
+}
+
+/*
+ * Corrects inner padding displayed oddly in S5, Chrome on OSX
+ */
+
+input[type="search"]::-webkit-search-decoration {
+ -webkit-appearance: none;
+}
+
+/*
+ * Corrects inner padding and border displayed oddly in FF3/4
+ * www.sitepen.com/blog/2008/05/14/the-devils-in-the-details-fixing-dojos-toolbar-buttons/
+ */
+
+button::-moz-focus-inner,
+input::-moz-focus-inner {
+ border: 0;
+ padding: 0;
+}
+
+/*
+ * 1. Removes default vertical scrollbar in IE6/7/8/9
+ * 2. Improves readability and alignment in all browsers
+ */
+
+textarea {
+ overflow: auto; /* 1 */
+ vertical-align: top; /* 2 */
+}
+
+
+/* =============================================================================
+ Tables
+ ========================================================================== */
+
+/*
+ * Remove most spacing between table cells
+ */
+
+table {
+ border-collapse: collapse;
+ border-spacing: 0;
+}
diff --git a/templates/pagenav.hamlet b/templates/pagenav.hamlet
new file mode 100644
index 0000000..ae38a2d
--- /dev/null
+++ b/templates/pagenav.hamlet
@@ -0,0 +1,10 @@
+<p>(page #{pageNumber}/#{pages}):
+
+$if doPrev
+ <a href=@{UserR cid}?page=#{prevPageNumber}>Prev
+$else
+ Prev
+$if doNext
+ <a href=@{UserR cid}?page=#{nextPageNumber}>Next
+$else
+ Next
diff --git a/templates/userpage.hamlet b/templates/userpage.hamlet
new file mode 100644
index 0000000..27353d0
--- /dev/null
+++ b/templates/userpage.hamlet
@@ -0,0 +1,21 @@
+<h1>#{username}
+
+$if isUser
+ <p>
+ <form method=post action=@{UserR cid}#form enctype=#{formEnctype}>
+ ^{formWidget}
+ <input type="submit" value="Submit time entry">
+$else
+
+<table>
+ <tr>
+ <th>Category
+ <th>Hours
+ <th>Date
+ $forall (a,b,c) <- entries
+ <tr .timeentry>
+ <td>#{a}
+ <td>#{b}
+ <td>#{c}
+
+^{pageNavWidget}
diff --git a/templates/userpage.lucius b/templates/userpage.lucius
new file mode 100644
index 0000000..29920d8
--- /dev/null
+++ b/templates/userpage.lucius
@@ -0,0 +1,2 @@
+tr.timeentry:nth-child(even) {background: #9f9}
+tr.timeentry:nth-child(odd) {background: #fff}
diff --git a/tests/HomeTest.hs b/tests/HomeTest.hs
new file mode 100644
index 0000000..17c9e6d
--- /dev/null
+++ b/tests/HomeTest.hs
@@ -0,0 +1,24 @@
+module HomeTest
+ ( homeSpecs
+ ) where
+
+import Import
+import Yesod.Test
+
+homeSpecs :: Specs
+homeSpecs =
+ describe "These are some example tests" $
+ it "loads the index and checks it looks right" $ do
+ get_ "/"
+ statusIs 200
+ htmlAllContain "h1" "Hello"
+
+ post "/" $ do
+ addNonce
+ fileByLabel "Choose a file" "tests/main.hs" "text/plain" -- talk about self-reference
+ byLabel "What's on the file?" "Some Content"
+
+ statusIs 200
+ htmlCount ".message" 1
+ htmlAllContain ".message" "Some Content"
+ htmlAllContain ".message" "text/plain"
diff --git a/tests/main.hs b/tests/main.hs
new file mode 100644
index 0000000..d475fe8
--- /dev/null
+++ b/tests/main.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Main where
+
+import Import
+import Settings
+import Yesod.Logger (defaultDevelopmentLogger)
+import Yesod.Default.Config
+import Yesod.Test
+import Application (makeFoundation)
+
+import HomeTest
+
+main :: IO a
+main = do
+ conf <- loadConfig $ (configSettings Testing) { csParseExtra = parseExtra }
+ logger <- defaultDevelopmentLogger
+ foundation <- makeFoundation conf logger
+ app <- toWaiAppPlain foundation
+ runTests app (connPool foundation) homeSpecs