slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

web: bump version, upgrade to yesod 0.10

Browse Source
This commit is contained in:
Simon Michael 2012-03-05 07:52:36 +00:00
parent 8492f6cae4
commit c27707f578
11 changed files with 317 additions and 283 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
hledger-web/Hledger/Web.hs
View File

@ -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

81
hledger-web/Hledger/Web/Application.hs
View File

@ -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

66
hledger-web/Hledger/Web/Foundation.hs
View File

@ -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

35
hledger-web/Hledger/Web/Handlers.hs
View File

@ -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|<span>Added transaction:<small><pre>#{chomp $ show t'}</pre></small>|]
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.

19
hledger-web/Hledger/Web/Import.hs Normal file
View File

@ -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

1
hledger-web/Hledger/Web/Options.hs
View File

@ -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

108
hledger-web/Hledger/Web/Settings.hs
View File

@ -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|]
-}

17
hledger-web/Hledger/Web/Settings/StaticFiles.hs
View File

@ -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)

174
hledger-web/hledger-web.cabal
View File

@ -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

91
hledger-web/hledger-web.hs
View File

@ -1,31 +1,32 @@
{-# LANGUAGE CPP #-}
{-|
hledger-web - a hledger add-on providing a web interface.
Copyright (c) 2007-2011 Simon Michael <simon@joyful.com>
Copyright (c) 2007-2012 Simon Michael <simon@joyful.com>
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

4
hledger-web/routes
View File

@ -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