From 025eb70c992914fbdf018c189d358ae250d2eeb1 Mon Sep 17 00:00:00 2001 From: Clint Adams Date: Mon, 22 Oct 2012 15:19:04 -0400 Subject: This needs to be cleaned and sanitized before publication. --- Application.hs | 62 ++++ Auth/Proxied.hs | 37 +++ Foundation.hs | 181 ++++++++++++ Handler/Home.hs | 39 +++ Handler/User.hs | 87 ++++++ Import.hs | 28 ++ Model.hs | 11 + Settings.hs | 68 +++++ Settings/Development.hs | 14 + Settings/StaticFiles.hs | 18 ++ config/models | 19 ++ config/routes | 8 + config/settings.yml | 19 ++ config/sqlite.yml | 20 ++ devel.hs | 26 ++ dist/build/autogen/Paths_sflctimekeeper.hs | 32 +++ main.hs | 8 + sflctimekeeper.cabal | 118 ++++++++ templates/default-layout-wrapper.hamlet | 47 +++ templates/default-layout.hamlet | 3 + templates/homepage.hamlet | 38 +++ templates/homepage.julius | 1 + templates/homepage.lucius | 6 + templates/normalize.lucius | 439 +++++++++++++++++++++++++++++ templates/pagenav.hamlet | 10 + templates/userpage.hamlet | 21 ++ templates/userpage.lucius | 2 + tests/HomeTest.hs | 24 ++ tests/main.hs | 22 ++ 29 files changed, 1408 insertions(+) create mode 100644 Application.hs create mode 100644 Auth/Proxied.hs create mode 100644 Foundation.hs create mode 100644 Handler/Home.hs create mode 100644 Handler/User.hs create mode 100644 Import.hs create mode 100644 Model.hs create mode 100644 Settings.hs create mode 100644 Settings/Development.hs create mode 100644 Settings/StaticFiles.hs create mode 100644 config/models create mode 100644 config/routes create mode 100644 config/settings.yml create mode 100644 config/sqlite.yml create mode 100644 devel.hs create mode 100644 dist/build/autogen/Paths_sflctimekeeper.hs create mode 100644 main.hs create mode 100644 sflctimekeeper.cabal create mode 100644 templates/default-layout-wrapper.hamlet create mode 100644 templates/default-layout.hamlet create mode 100644 templates/homepage.hamlet create mode 100644 templates/homepage.julius create mode 100644 templates/homepage.lucius create mode 100644 templates/normalize.lucius create mode 100644 templates/pagenav.hamlet create mode 100644 templates/userpage.hamlet create mode 100644 templates/userpage.lucius create mode 100644 tests/HomeTest.hs create mode 100644 tests/main.hs 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: # + 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 @@ +\ +\ +\ +\ +\ + + + + + #{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 -- cgit v1.2.1