mirror of
https://github.com/simonmichael/hledger.git
synced 2024-09-20 10:47:29 +03:00
102 lines
3.6 KiB
Haskell
102 lines
3.6 KiB
Haskell
{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module App
|
|
( App (..)
|
|
, AppRoute (..)
|
|
, resourcesApp
|
|
, Handler
|
|
, Widget
|
|
, module Yesod.Core
|
|
, module Settings
|
|
, StaticRoute (..)
|
|
, lift
|
|
, liftIO
|
|
) where
|
|
|
|
import Control.Monad.Trans.Class (lift)
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import qualified Data.Text as T
|
|
import System.Directory
|
|
import qualified Data.ByteString.Lazy as L
|
|
import Yesod.Core
|
|
import Yesod.Helpers.Static
|
|
|
|
import Hledger.Cli.Options
|
|
import Hledger.Data
|
|
|
|
import Settings
|
|
import StaticFiles
|
|
|
|
-- | 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
|
|
{getStatic :: Static -- ^ Settings for static file serving.
|
|
,appRoot :: T.Text
|
|
,appOpts :: [Opt]
|
|
,appArgs :: [String]
|
|
,appJournal :: Journal
|
|
}
|
|
|
|
-- | A useful synonym; most of the handler functions in your application
|
|
-- will need to be of this type.
|
|
type Handler = GHandler App App
|
|
|
|
-- | A useful synonym; most of the widgets functions in your application
|
|
-- will need to be of this type.
|
|
type Widget = GWidget App App
|
|
|
|
-- This is where we define all of the routes in our application. For a full
|
|
-- explanation of the syntax, please see:
|
|
-- http://docs.yesodweb.com/book/web-routes-quasi/
|
|
--
|
|
-- 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 Controller.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 "routes")
|
|
|
|
-- 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 = appRoot
|
|
|
|
defaultLayout widget = do
|
|
mmsg <- getMessage
|
|
pc <- widgetToPageContent $ do
|
|
widget
|
|
addCassius $(Settings.cassiusFile "default-layout")
|
|
hamletToRepHtml $(Settings.hamletFile "default-layout")
|
|
|
|
-- This is done to provide an optimization for serving static files from
|
|
-- a separate domain. Please see the staticroot setting in Settings.hs
|
|
-- urlRenderOverride a (StaticR s) =
|
|
-- Just $ uncurry (joinPath a Settings.staticroot) $ renderRoute s
|
|
-- urlRenderOverride _ _ = Nothing
|
|
|
|
-- 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 ext' _ content = do
|
|
let fn = base64md5 content ++ '.' : T.unpack ext'
|
|
let statictmp = Settings.staticdir ++ "/tmp/"
|
|
liftIO $ createDirectoryIfMissing True statictmp
|
|
let fn' = statictmp ++ fn
|
|
exists <- liftIO $ doesFileExist fn'
|
|
unless exists $ liftIO $ L.writeFile fn' content
|
|
return $ Just $ Right (StaticR $ StaticRoute ["tmp", T.pack fn] [], [])
|
|
|