diff --git a/hledger-web/Hledger/Web.hs b/hledger-web/Hledger/Web.hs index 41996a15d..16730fc04 100644 --- a/hledger-web/Hledger/Web.hs +++ b/hledger-web/Hledger/Web.hs @@ -6,6 +6,7 @@ module Hledger.Web ( module Hledger.Web.Foundation, module Hledger.Web.Application, module Hledger.Web.Handlers, + module Hledger.Web.Import, module Hledger.Web.Options, module Hledger.Web.Settings, module Hledger.Web.Settings.StaticFiles, @@ -17,6 +18,7 @@ import Test.HUnit import Hledger.Web.Foundation import Hledger.Web.Application import Hledger.Web.Handlers +import Hledger.Web.Import import Hledger.Web.Options import Hledger.Web.Settings import Hledger.Web.Settings.StaticFiles diff --git a/hledger-web/Hledger/Web/Application.hs b/hledger-web/Hledger/Web/Application.hs index 47ce7713d..71581db64 100644 --- a/hledger-web/Hledger/Web/Application.hs +++ b/hledger-web/Hledger/Web/Application.hs @@ -3,61 +3,64 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Hledger.Web.Application ( - withApp - ,withDevelAppPort - ) +module Hledger.Web.Application + ( getApplication + , getApplicationDev + ) where -import Data.Dynamic (Dynamic, toDyn) +import Yesod.Default.Config +import Yesod.Default.Main (defaultDevelApp) +import Yesod.Default.Handlers (getRobotsR) +#if DEVELOPMENT +import Yesod.Logger (Logger, logBS) +import Network.Wai.Middleware.RequestLogger (logCallbackDev) +#else +import Yesod.Logger (Logger, logBS, toProduction) +import Network.Wai.Middleware.RequestLogger (logCallback) +#endif import Network.Wai (Application) -import Network.Wai.Middleware.Debug (debugHandle) -import Yesod.Core hiding (AppConfig,loadConfig,appPort) -import Yesod.Logger (makeLogger, flushLogger, Logger, logLazyText, logString) -import Yesod.Static import Hledger.Web.Foundation import Hledger.Web.Handlers import Hledger.Web.Options -import Hledger.Web.Settings +import Hledger.Web.Settings (parseExtra) +import Hledger.Web.Settings.StaticFiles (staticSite) -- This line actually creates our YesodSite instance. It is the second half -- of the call to mkYesodData which occurs in App.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. -withApp :: AppConfig -> Logger -> WebOpts -> (Application -> IO a) -> IO a -withApp conf logger opts f = do -#ifdef PRODUCTION - putStrLn $ "Production mode, using embedded web files" - let s = $(embed staticDir) +getApplication :: AppConfig DefaultEnv Extra -> Logger -> IO Application +getApplication conf logger = do + s <- staticSite + let foundation = App conf setLogger s defwebopts -- XXX + app <- toWaiAppPlain foundation + return $ logWare app + where +#ifdef DEVELOPMENT + logWare = logCallbackDev (logBS setLogger) + setLogger = logger #else - putStrLn $ "Not in production mode, using web files from " ++ staticDir ++ "/" - s <- staticDevel staticDir + setLogger = toProduction logger -- by default the logger is set for development + logWare = logCallback (logBS setLogger) #endif - let a = App {settings=conf - ,getLogger=logger - ,getStatic=s - ,appOpts=opts - } - toWaiApp a >>= f -- for yesod devel -withDevelAppPort :: Dynamic -withDevelAppPort = - toDyn go +getApplicationDev :: IO (Int, Application) +getApplicationDev = + defaultDevelApp loader getApplication where - go :: ((Int, Application) -> IO ()) -> IO () - go f = do - conf <- loadConfig Development - let port = appPort conf - logger <- makeLogger - logString logger $ "Devel application launched with default options, listening on port " ++ show port - withApp conf logger defwebopts $ \app -> f (port, debugHandle (logHandle logger) app) - flushLogger logger - where - logHandle logger msg = logLazyText logger msg >> flushLogger logger + loader = loadConfig (configSettings Development) + { csParseExtra = parseExtra + } + +-- #ifdef PRODUCTION +-- putStrLn $ "Production mode, using embedded web files" +-- let s = $(embed staticDir) +-- #else +-- putStrLn $ "Not in production mode, using web files from " ++ staticDir ++ "/" +-- s <- staticDevel staticDir +-- #endif + diff --git a/hledger-web/Hledger/Web/Foundation.hs b/hledger-web/Hledger/Web/Foundation.hs index 76c615d27..8d1016060 100644 --- a/hledger-web/Hledger/Web/Foundation.hs +++ b/hledger-web/Hledger/Web/Foundation.hs @@ -1,30 +1,30 @@ -{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-} + module Hledger.Web.Foundation ( App (..) - , AppRoute (..) + , Route (..) + -- , AppMessage (..) , resourcesApp , Handler , Widget - , StaticRoute (..) - , lift + , module Yesod.Core + , module Hledger.Web.Settings , liftIO ) where -import Control.Monad (unless) +import Prelude +import Yesod.Core hiding (Route) +import Yesod.Default.Config +import Yesod.Default.Util (addStaticContentExternal) +import Yesod.Static +import Yesod.Logger (Logger, logMsg, formatLogText) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Class (lift) -import System.Directory -import Text.Hamlet hiding (hamletFile) import Web.ClientSession (getKey) -import Yesod.Core -import Yesod.Logger (Logger, logLazyText) -import Yesod.Static (Static, base64md5, StaticRoute(..)) -import qualified Data.ByteString.Lazy as L -import qualified Data.Text as T +import Text.Hamlet import Hledger.Web.Options -import Hledger.Web.Settings +import qualified Hledger.Web.Settings +import Hledger.Web.Settings (Extra (..), widgetFile) import Hledger.Web.Settings.StaticFiles @@ -33,7 +33,7 @@ import Hledger.Web.Settings.StaticFiles -- starts running, such as database connections. Every handler will have -- access to the data present here. data App = App - { settings :: Hledger.Web.Settings.AppConfig + { settings :: AppConfig DefaultEnv Extra , getLogger :: Logger , getStatic :: Static -- ^ Settings for static file serving. @@ -41,6 +41,9 @@ data App = App -- ,appJournal :: Journal } +-- 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://docs.yesodweb.com/book/web-routes-quasi/ @@ -65,14 +68,27 @@ 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 = Hledger.Web.Settings.appRoot . settings + -- approot = Hledger.Web.Settings.appRoot . settings + approot = ApprootMaster $ appRoot . settings -- Place the session key file in the config folder encryptKey _ = fmap Just $ getKey "client_session_key.aes" defaultLayout widget = do - -- mmsg <- getMessage + 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") + -- $(widgetFile "default-layout") + -- hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet") + widget -- addCassius $(cassiusFile "default-layout") -- hamletToRepHtml $(hamletFile "default-layout") @@ -102,17 +118,13 @@ instance Yesod App where -- urlRenderOverride _ _ = Nothing messageLogger y loc level msg = - formatLogMessage loc level msg >>= logLazyText (getLogger y) + 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 ext' _ content = do - let fn = base64md5 content ++ '.' : T.unpack ext' - let statictmp = Hledger.Web.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] [], []) + addStaticContent = addStaticContentExternal (const $ Left ()) base64md5 Hledger.Web.Settings.staticDir (StaticR . flip StaticRoute []) + + -- Place Javascript at bottom of the body tag so the rest of the page loads first + jsLoader _ = BottomOfBody diff --git a/hledger-web/Hledger/Web/Handlers.hs b/hledger-web/Hledger/Web/Handlers.hs index 742c16208..8cd9b7401 100644 --- a/hledger-web/Hledger/Web/Handlers.hs +++ b/hledger-web/Hledger/Web/Handlers.hs @@ -7,8 +7,9 @@ hledger-web's request handlers, and helpers. module Hledger.Web.Handlers where +import Prelude import Control.Applicative ((<$>)) -import Data.Aeson +-- import Data.Aeson import Data.ByteString (ByteString) import Data.Either (lefts,rights) import Data.List @@ -25,7 +26,7 @@ import Text.Blaze (preEscapedString, toHtml) import Text.Hamlet hiding (hamletFile) import Text.Printf import Yesod.Core -import Yesod.Json +-- import Yesod.Json import Hledger hiding (today) import Hledger.Cli hiding (version) @@ -34,14 +35,16 @@ import Hledger.Web.Options import Hledger.Web.Settings -getFaviconR :: Handler () -getFaviconR = sendFile "image/x-icon" $ Hledger.Web.Settings.staticDir "favicon.ico" +-- getFaviconR :: Handler () +-- getFaviconR = sendFile "image/x-icon" $ Hledger.Web.Settings.staticDir "favicon.ico" -getRobotsR :: Handler RepPlain -getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString) +-- getRobotsR :: Handler RepPlain +-- getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString) getRootR :: Handler RepHtml -getRootR = redirect RedirectTemporary defaultroute where defaultroute = RegisterR +getRootR = redirect defaultroute where defaultroute = RegisterR + +type AppRoute = Route App ---------------------------------------------------------------------- -- main views: @@ -165,6 +168,7 @@ getRegisterOnlyR = do ---------------------------------------------------------------------- +{- -- | A simple accounts view. This one is json-capable, returning the chart -- of accounts as json if the Accept header specifies json. getAccountsR :: Handler RepHtmlJson @@ -183,6 +187,7 @@ getAccountsJsonR = do VD{..} <- getViewData let j' = filterJournalPostings2 m j jsonToRepJson $ jsonMap [("accounts", toJSON $ journalAccountNames j')] +-} ---------------------------------------------------------------------- -- view helpers @@ -521,7 +526,7 @@ handleAdd = do -- setMessage $ toHtml $ (printf "Added transaction:\n%s" (show t') :: String) setMessage [$shamlet|Added transaction:
#{chomp $ show t'}
|] - redirectParams RedirectTemporary RegisterR [("add","1")] + redirect (RegisterR, [("add","1")]) chomp :: String -> String chomp = reverse . dropWhile (`elem` "\r\n") . reverse @@ -548,7 +553,7 @@ handleEdit = do if not $ null errs then do setMessage $ toHtml (intercalate "; " errs :: String) - redirect RedirectTemporary JournalR + redirect JournalR else do -- try to avoid unnecessary backups or saving invalid data @@ -559,24 +564,24 @@ handleEdit = do if not changed then do setMessage "No change" - redirect RedirectTemporary JournalR + redirect JournalR else do jE <- liftIO $ readJournal Nothing Nothing (Just journalpath) tnew either (\e -> do setMessage $ toHtml e - redirect RedirectTemporary JournalR) + redirect JournalR) (const $ do liftIO $ writeFileWithBackup journalpath tnew setMessage $ toHtml (printf "Saved journal %s\n" (show journalpath) :: String) - redirect RedirectTemporary JournalR) + redirect JournalR) jE -- | Handle a post from the journal import form. handleImport :: Handler RepHtml handleImport = do setMessage "can't handle file upload yet" - redirect RedirectTemporary JournalR + redirect JournalR -- -- get form input values, or basic validation errors. E means an Either value. -- fileM <- runFormPost $ maybeFileInput "file" -- let fileE = maybe (Left "No file provided") Right fileM @@ -584,11 +589,11 @@ handleImport = do -- case fileE of -- Left errs -> do -- setMessage errs - -- redirect RedirectTemporary JournalR + -- redirect JournalR -- Right s -> do -- setMessage s - -- redirect RedirectTemporary JournalR + -- redirect JournalR ---------------------------------------------------------------------- -- | Other view components. diff --git a/hledger-web/Hledger/Web/Import.hs b/hledger-web/Hledger/Web/Import.hs new file mode 100644 index 000000000..64e1885da --- /dev/null +++ b/hledger-web/Hledger/Web/Import.hs @@ -0,0 +1,19 @@ +module Hledger.Web.Import + ( module Prelude + , module Hledger.Web.Foundation + , (<>) + , Text + , module Data.Monoid + , module Control.Applicative + ) where + +import Prelude hiding (writeFile, readFile, putStrLn) +import Data.Monoid (Monoid (mappend, mempty, mconcat)) +import Control.Applicative ((<$>), (<*>), pure) +import Data.Text (Text) + +import Hledger.Web.Foundation + +infixr 5 <> +(<>) :: Monoid m => m -> m -> m +(<>) = mappend diff --git a/hledger-web/Hledger/Web/Options.hs b/hledger-web/Hledger/Web/Options.hs index 5b3a04352..b4cee55ca 100644 --- a/hledger-web/Hledger/Web/Options.hs +++ b/hledger-web/Hledger/Web/Options.hs @@ -5,6 +5,7 @@ module Hledger.Web.Options where +import Prelude import Data.Maybe import Distribution.PackageDescription.TH (packageVariable, package, pkgName, pkgVersion) import System.Console.CmdArgs diff --git a/hledger-web/Hledger/Web/Settings.hs b/hledger-web/Hledger/Web/Settings.hs index d522bcfb6..84a90799c 100644 --- a/hledger-web/Hledger/Web/Settings.hs +++ b/hledger-web/Hledger/Web/Settings.hs @@ -7,17 +7,18 @@ -- by overriding methods in the Yesod typeclass. That instance is -- declared in the hledger-web.hs file. module Hledger.Web.Settings - ( hamletFile - , cassiusFile - , juliusFile - , luciusFile - , widgetFile + ( widgetFile , staticRoot , staticDir - , loadConfig - , AppEnvironment(..) - , AppConfig(..) + , Extra (..) + , parseExtra + -- , hamletFile + -- , cassiusFile + -- , juliusFile + -- , luciusFile + -- , AppEnvironment(..) + -- , AppConfig(..) , defport , defbaseurl , hledgerorgurl @@ -25,20 +26,26 @@ module Hledger.Web.Settings ) where -import qualified Text.Hamlet as S -import qualified Text.Cassius as S -import qualified Text.Julius as S -import qualified Text.Lucius as S +import Prelude +import Text.Shakespeare.Text (st) +import Language.Haskell.TH.Syntax +import Yesod.Default.Config +import qualified Yesod.Default.Util +import Data.Text (Text) +import Data.Yaml +import Control.Applicative + +-- import qualified Text.Hamlet as S +-- import qualified Text.Cassius as S +-- import qualified Text.Julius as S +-- import qualified Text.Lucius as S import Text.Printf import qualified Text.Shakespeare.Text as S import Text.Shakespeare.Text (st) -import Language.Haskell.TH.Syntax import Yesod.Widget (addWidget, addCassius, addJulius, addLucius, whamletFile) import Data.Monoid (mempty) import System.Directory (doesFileExist) -import Data.Text (Text, pack) -import Data.Object -import qualified Data.Object.Yaml as YAML +import Data.Text (pack) import Control.Monad (join) @@ -54,54 +61,8 @@ defbaseurl :: Int -> String defbaseurl port = printf "http://localhost:%d" port -data AppEnvironment = Test - | Development - | Staging - | Production - deriving (Eq, Show, Read, Enum, Bounded) - -- | Dynamic per-environment configuration loaded from the YAML file Settings.yaml. -- Use dynamic settings to avoid the need to re-compile the application (between staging and production environments). --- --- By convention these settings should be overwritten by any command line arguments. --- See config/App.hs for command line arguments --- Command line arguments provide some convenience but are also required for hosting situations where a setting is read from the environment (appPort on Heroku). --- -data AppConfig = AppConfig { - appEnv :: AppEnvironment - - , appPort :: Int - - -- The base URL for your application. This will usually be different for - -- development and production. Yesod automatically constructs URLs for you, - -- so this value must be accurate to create valid links. - -- Please note that there is no trailing slash. - -- - -- You probably want to change this! If your domain name was "yesod.com", - -- you would probably want it to be: - -- > "http://yesod.com" - , appRoot :: Text -} deriving (Show) - -loadConfig :: AppEnvironment -> IO AppConfig -loadConfig env = do - allSettings <- (join $ YAML.decodeFile ("config/settings.yml" :: String)) >>= fromMapping - settings <- lookupMapping (show env) allSettings - hostS <- lookupScalar "host" settings - port <- fmap read $ lookupScalar "port" settings - return $ AppConfig { - appEnv = env - , appPort = port - , appRoot = pack $ hostS ++ addPort port - } - where - addPort :: Int -> String -#ifdef PRODUCTION - addPort _ = "" -#else - addPort p = ":" ++ (show p) -#endif - -- | 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 @@ -120,9 +81,27 @@ staticDir = "static" -- have to make a corresponding change here. -- -- To see how this value is used, see urlRenderOverride in hledger-web.hs -staticRoot :: AppConfig -> Text -staticRoot conf = [$st|#{appRoot conf}/static|] +staticRoot :: AppConfig DefaultEnv a -> Text +staticRoot conf = [st|#{appRoot conf}/static|] +widgetFile :: String -> Q Exp +#if DEVELOPMENT +widgetFile = Yesod.Default.Util.widgetFileReload +#else +widgetFile = Yesod.Default.Util.widgetFileNoReload +#endif + +data Extra = Extra + { extraCopyright :: Text + , extraAnalytics :: Maybe Text -- ^ Google Analytics + } + +parseExtra :: DefaultEnv -> Object -> Parser Extra +parseExtra _ o = Extra + <$> o .: "copyright" + <*> o .:? "analytics" + +{- -- The rest of this file contains settings which rarely need changing by a -- user. @@ -190,3 +169,4 @@ widgetFile x = do whenExists tofn f = do e <- qRunIO $ doesFileExist $ tofn x if e then f x else [|mempty|] +-} \ No newline at end of file diff --git a/hledger-web/Hledger/Web/Settings/StaticFiles.hs b/hledger-web/Hledger/Web/Settings/StaticFiles.hs index 1fef26459..00054bcb7 100644 --- a/hledger-web/Hledger/Web/Settings/StaticFiles.hs +++ b/hledger-web/Hledger/Web/Settings/StaticFiles.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, CPP #-} {-| This module exports routes for all the files in the static directory at @@ -11,8 +11,23 @@ This is a separate module to satisfy template haskell requirements. -} module Hledger.Web.Settings.StaticFiles where +import Prelude (IO) import Yesod.Static +import qualified Yesod.Static as Static import Hledger.Web.Settings (staticDir) +-- | use this to create your static file serving site +staticSite :: IO Static.Static +staticSite = +#ifdef DEVELOPMENT + Static.staticDevel staticDir +#else + Static.static staticDir +#endif + +-- | 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 staticDir) diff --git a/hledger-web/hledger-web.cabal b/hledger-web/hledger-web.cabal index c225fe8ad..de3805a26 100644 --- a/hledger-web/hledger-web.cabal +++ b/hledger-web/hledger-web.cabal @@ -1,5 +1,5 @@ name: hledger-web -version: 0.17.1 +version: 0.17.98 category: Finance synopsis: A web interface for the hledger accounting tool. description: @@ -39,90 +39,128 @@ source-repository head type: darcs location: http://joyful.com/repos/hledger -Flag production - Description: Build fully optimised and with web files embedded (not loaded from ./static/) - Default: True +-- Flag production +-- Description: Build fully optimised and with web files embedded (not loaded from ./static/) +-- Default: True flag threaded - Description: Build with support for multithreaded execution + Description: Build with support for multithreaded execution. Default: True -Flag devel - Description: Build for auto-recompiling by "yesod devel" +flag dev + Description: Turn on development settings, like auto-reload templates. Default: False -executable hledger-web - main-is: hledger-web.hs - if flag(devel) - Buildable: False - if flag(production) - cpp-options: -DPRODUCTION - ghc-options: -O2 - else - ghc-options: -Wall - if flag(threaded) - ghc-options: -threaded - other-modules: - Hledger.Web - Hledger.Web.Foundation - Hledger.Web.Application - Hledger.Web.Options - Hledger.Web.Settings - Hledger.Web.Settings.StaticFiles - Hledger.Web.Handlers - build-depends: - hledger == 0.17 - ,hledger-lib == 0.17 - ,HUnit - ,base >= 4 && < 5 - ,bytestring - ,cabal-file-th - ,cmdargs >= 0.9.1 && < 0.10 - ,directory - ,filepath - ,old-locale - ,parsec - ,regexpr >= 0.5.1 - ,safe >= 0.2 - ,text - ,time - ,io-storage >= 0.3 && < 0.4 - ,failure >= 0.1 && < 0.2 - ,file-embed == 0.0.* - ,template-haskell >= 2.4 && < 2.8 - - ,yesod == 0.9.4.1 - ,yesod-core - ,yesod-form - ,yesod-json - ,yesod-static >= 0.3 && < 0.10 - ,aeson >= 0.3.2.13 - ,blaze-html - ,clientsession - ,data-object - ,data-object-yaml - ,hamlet - ,shakespeare-css - ,shakespeare-js - ,shakespeare-text - ,transformers - ,wai < 1.0 - ,wai-extra < 1.0 - ,warp < 1.0 - ,http-enumerator < 0.7.3 - ,tls-extra < 0.4.3 +flag library-only + Description: Build for use with "yesod devel" + Default: False library - if flag(devel) + if flag(library-only) Buildable: True else Buildable: False + + if flag(threaded) + ghc-options: -threaded + exposed-modules: Hledger.Web.Application other-modules: Hledger.Web Hledger.Web.Foundation + Hledger.Web.Import Hledger.Web.Options Hledger.Web.Settings Hledger.Web.Settings.StaticFiles Hledger.Web.Handlers + + ghc-options: -Wall -O0 -fno-warn-unused-do-bind + cpp-options: -DDEVELOPMENT + + extensions: TemplateHaskell + QuasiQuotes + OverloadedStrings + NoImplicitPrelude + CPP + OverloadedStrings + MultiParamTypeClasses + TypeFamilies + +executable hledger-web + if flag(library-only) + Buildable: False + + if flag(dev) + cpp-options: -DDEVELOPMENT + ghc-options: -Wall -O0 -fno-warn-unused-do-bind + else + ghc-options: -Wall -O2 -fno-warn-unused-do-bind + + if flag(threaded) + ghc-options: -threaded + + extensions: TemplateHaskell + QuasiQuotes + OverloadedStrings + NoImplicitPrelude + CPP + OverloadedStrings + MultiParamTypeClasses + TypeFamilies + + main-is: hledger-web.hs + + other-modules: + Hledger.Web + Hledger.Web.Foundation + Hledger.Web.Application + Hledger.Web.Import + Hledger.Web.Options + Hledger.Web.Settings + Hledger.Web.Settings.StaticFiles + Hledger.Web.Handlers + + build-depends: + hledger == 0.17 + , hledger-lib == 0.17 + + , cabal-file-th + , cmdargs >= 0.9.1 && < 0.10 + , directory + , filepath + , HUnit + , old-locale + , parsec + , regexpr >= 0.5.1 + , safe >= 0.2 + , time + , io-storage >= 0.3 && < 0.4 + , file-embed == 0.0.* + + , base >= 4 && < 5 + , blaze-html >= 0.4.3.1 && < 0.5 + , yesod-core >= 0.10 && < 0.11 + , yesod-static >= 0.10 && < 0.11 + , yesod-default >= 0.6 && < 0.7 + , clientsession >= 0.7.3 && < 0.8 + , bytestring >= 0.9 && < 0.10 + , text >= 0.11 && < 0.12 + , template-haskell + , hamlet >= 0.10 && < 0.11 + , shakespeare-text >= 0.10 && < 0.11 + , wai >= 1.1 && < 1.2 + , wai-extra >= 1.1 && < 1.2 + , transformers >= 0.2 && < 0.3 + , monad-control >= 0.3 && < 0.4 + , yaml >= 0.5 && < 0.6 + , warp >= 1.1.0.1 && < 1.2 + + + -- if flag(production) + -- cpp-options: -DPRODUCTION + -- ghc-options: -O2 + -- else + -- ghc-options: -Wall + -- if flag(threaded) + -- ghc-options: -threaded diff --git a/hledger-web/hledger-web.hs b/hledger-web/hledger-web.hs index 186ca6c13..044667691 100644 --- a/hledger-web/hledger-web.hs +++ b/hledger-web/hledger-web.hs @@ -1,31 +1,32 @@ {-# LANGUAGE CPP #-} {-| + hledger-web - a hledger add-on providing a web interface. -Copyright (c) 2007-2011 Simon Michael +Copyright (c) 2007-2012 Simon Michael Released under GPL version 3 or later. + -} module Main where --- import Control.Concurrent (forkIO, threadDelay) +import Network.Wai.Handler.Warp (runSettings, defaultSettings, settingsPort) +import Yesod.Default.Config +import Yesod.Default.Main (defaultMain) +import Yesod.Logger (Logger, defaultDevelopmentLogger) --, logString) + +import Prelude hiding (putStrLn) +-- -- import Control.Concurrent (forkIO, threadDelay) import Control.Monad -import Data.Maybe +-- import Data.Maybe import Data.Text(pack) -import Network.Wai.Handler.Warp (run) import System.Exit import System.IO.Storage (withStore, putValue) import Text.Printf -#ifndef PRODUCTION -import Network.Wai.Middleware.Debug (debugHandle) -import Yesod.Logger (logString, logLazyText, flushLogger, makeLogger) -#else -import Yesod.Logger (makeLogger) -#endif import Hledger import Hledger.Cli hiding (progname,prognameandversion) -import Prelude hiding (putStrLn) +import Hledger.Web.Settings (parseExtra) import Hledger.Utils.UTF8IOCompat (putStrLn) import Hledger.Web @@ -74,61 +75,19 @@ server baseurl port opts j = do withStore "hledger" $ do putValue "hledger" "journal" j - -- yesod main - logger <- makeLogger - -- args <- cmdArgs argConfig - -- env <- getAppEnv args - let env = Development - -- c <- loadConfig env - -- let c' = if port_ opts /= 0 - -- then c{ appPort = port args } - -- else c - let c = AppConfig { - appEnv = env +-- defaultMain :: (Show env, Read env) +-- => IO (AppConfig env extra) +-- -> (AppConfig env extra -> Logger -> IO Application) +-- -> IO () +-- defaultMain load getApp = do + -- config <- fromArgs parseExtra + let config = AppConfig { + appEnv = Development , appPort = port_ opts , appRoot = pack baseurl } -#if PRODUCTION - withApp c logger opts $ run (appPort c) -#else - logString logger $ (show env) ++ " application launched, listening on port " ++ show (appPort c) - withApp c logger opts $ run (appPort c) . debugHandle (logHandle logger) - flushLogger logger - - where - logHandle logger msg = logLazyText logger msg >> flushLogger logger -#endif - --- data ArgConfig = ArgConfig --- { environment :: String --- , port :: Int --- } deriving (Show, Data, Typeable) - --- argConfig :: ArgConfig --- argConfig = ArgConfig --- { environment = def --- &= help ("application environment, one of: " ++ (foldl1 (\a b -> a ++ ", " ++ b) environments)) --- &= typ "ENVIRONMENT" --- , port = def --- &= typ "PORT" --- } - --- environments :: [String] --- environments = map ((map toLower) . show) ([minBound..maxBound] :: [AppEnvironment]) - --- | retrieve the -e environment option --- getAppEnv :: ArgConfig -> IO AppEnvironment --- getAppEnv cfg = do --- let e = if environment cfg /= "" --- then environment cfg --- else --- #if PRODUCTION --- "production" --- #else --- "development" --- #endif --- return $ read $ capitalize e - --- where --- capitalize [] = [] --- capitalize (x:xs) = toUpper x : map toLower xs + logger <- defaultDevelopmentLogger + app <- getApplication config logger + runSettings defaultSettings + { settingsPort = appPort config + } app diff --git a/hledger-web/routes b/hledger-web/routes index 2ef5f5877..426e68266 100644 --- a/hledger-web/routes +++ b/hledger-web/routes @@ -6,5 +6,5 @@ /journal/entries JournalEntriesR GET POST /journal/edit JournalEditR GET POST /register RegisterR GET POST -/accounts AccountsR GET -/api/accounts AccountsJsonR GET +-- /accounts AccountsR GET +-- /api/accounts AccountsJsonR GET