95 lines
3.4 KiB
Haskell
95 lines
3.4 KiB
Haskell
{-|
|
|
Complete the definition of the web app begun in App.hs.
|
|
This is always done in two files for (TH?) reasons.
|
|
-}
|
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
|
|
module Hledger.Web.Application
|
|
( makeApplication
|
|
, makeApp
|
|
, makeAppWith
|
|
) where
|
|
|
|
import Data.IORef (newIORef, writeIORef)
|
|
import Network.Wai.Middleware.RequestLogger (logStdoutDev, logStdout)
|
|
import Network.HTTP.Client (defaultManagerSettings)
|
|
import Network.HTTP.Conduit (newManager)
|
|
import Yesod.Default.Config
|
|
import Yesod.Static (staticDevel, Static(Static))
|
|
import WaiAppStatic.Types (StaticSettings(..), LookupResult(LRNotFound), MaxAge(NoMaxAge))
|
|
import Control.Applicative ((<|>))
|
|
import Control.Monad (sequence)
|
|
import System.FilePath (takeDirectory, (</>))
|
|
import System.Directory (doesDirectoryExist)
|
|
|
|
import Hledger.Data (Journal(jfiles), nulljournal)
|
|
|
|
import Hledger.Web.Handler.AddR
|
|
import Hledger.Web.Handler.MiscR
|
|
import Hledger.Web.Handler.EditR
|
|
import Hledger.Web.Handler.UploadR
|
|
import Hledger.Web.Handler.JournalR
|
|
import Hledger.Web.Handler.RegisterR
|
|
import Hledger.Web.Import
|
|
import Hledger.Web.WebOptions (ServerMode(..), WebOpts(server_mode_, document_directory_), corsPolicy)
|
|
|
|
-- mkYesodDispatch creates our YesodDispatch instance.
|
|
-- It complements the mkYesodData call in App.hs,
|
|
-- but must be in a separate file for (TH?) reasons.
|
|
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 :: WebOpts -> Journal -> AppConfig DefaultEnv Extra -> IO Application
|
|
makeApplication opts' j' conf' = do
|
|
app <- makeAppWith j' conf' opts'
|
|
writeIORef (appJournal app) j'
|
|
(logWare . (corsPolicy opts')) <$> toWaiApp app
|
|
where
|
|
logWare | development = logStdoutDev
|
|
| server_mode_ opts' `elem` [Serve, ServeJson] = logStdout
|
|
| otherwise = id
|
|
|
|
makeApp :: AppConfig DefaultEnv Extra -> WebOpts -> IO App
|
|
makeApp = makeAppWith nulljournal
|
|
|
|
-- Make an "App" (defined in App.hs),
|
|
-- with the given Journal as its state
|
|
-- and the given "AppConfig" and "WebOpts" as its configuration.
|
|
makeAppWith :: Journal -> AppConfig DefaultEnv Extra -> WebOpts -> IO App
|
|
makeAppWith j' aconf wopts = do
|
|
s <- staticSite
|
|
let ddd = fmap ((</> "tositteet") . takeDirectory . fst) . listToMaybe $ jfiles j'
|
|
when pred a = (\x -> if x then Just a else Nothing) <$> pred
|
|
defaultDocumentDir <- fmap join . sequence $ (when <$> doesDirectoryExist <*> id) <$> ddd
|
|
let documentDir = document_directory_ wopts <|> defaultDocumentDir
|
|
nullStatic = Static $ StaticSettings
|
|
{ ssLookupFile = const $ pure LRNotFound
|
|
, ssGetMimeType = const $ pure ""
|
|
, ssIndices = []
|
|
, ssListing = Nothing
|
|
, ssMaxAge = NoMaxAge
|
|
, ssMkRedirect = const id
|
|
, ssRedirectToIndex = False
|
|
, ssUseHash = False
|
|
, ssAddTrailingSlash = True
|
|
, ss404Handler = Nothing
|
|
}
|
|
documentStatic <- sequence $ staticDevel <$> documentDir
|
|
m <- newManager defaultManagerSettings
|
|
jref <- newIORef j'
|
|
return App{
|
|
settings = aconf
|
|
, getStatic = s
|
|
, getDocument = fromMaybe nullStatic documentStatic
|
|
, httpManager = m
|
|
, appOpts = wopts
|
|
, appJournal = jref
|
|
}
|