hledger-web-1.2/Handler/0000755000000000000000000000000013042412664013306 5ustar0000000000000000hledger-web-1.2/Hledger/0000755000000000000000000000000012716736331013312 5ustar0000000000000000hledger-web-1.2/Hledger/Web/0000755000000000000000000000000013066746043014027 5ustar0000000000000000hledger-web-1.2/Settings/0000755000000000000000000000000012716736331013540 5ustar0000000000000000hledger-web-1.2/app/0000755000000000000000000000000013033310761012504 5ustar0000000000000000hledger-web-1.2/config/0000755000000000000000000000000012716736331013205 5ustar0000000000000000hledger-web-1.2/doc/0000755000000000000000000000000013067102144012472 5ustar0000000000000000hledger-web-1.2/messages/0000755000000000000000000000000012440136651013540 5ustar0000000000000000hledger-web-1.2/static/0000755000000000000000000000000013035510426013215 5ustar0000000000000000hledger-web-1.2/static/css/0000755000000000000000000000000012716736331014017 5ustar0000000000000000hledger-web-1.2/static/fonts/0000755000000000000000000000000012716736331014360 5ustar0000000000000000hledger-web-1.2/static/js/0000755000000000000000000000000012716736331013643 5ustar0000000000000000hledger-web-1.2/templates/0000755000000000000000000000000013035510426013724 5ustar0000000000000000hledger-web-1.2/tests/0000755000000000000000000000000012724070651013075 5ustar0000000000000000hledger-web-1.2/Application.hs0000644000000000000000000000552613035510426014535 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP, OverloadedStrings, TemplateHaskell #-} module Application ( makeApplication , getApplicationDev , makeFoundation ) where import Data.IORef import Import import Yesod.Default.Config import Yesod.Default.Main import Yesod.Default.Handlers import Network.Wai.Middleware.RequestLogger (logStdoutDev, logStdout) import Network.HTTP.Conduit (newManager) import Prelude (head) -- adapt to http-conduit 1.x or 2.x when cabal macros are available, otherwise assume 2.x #ifdef MIN_VERSION_http_conduit #if MIN_VERSION_http_conduit(2,0,0) #define http_conduit_2 #endif #else #define http_conduit_2 #endif #ifdef http_conduit_2 import Network.HTTP.Client (defaultManagerSettings) #else import Network.HTTP.Conduit (def) #endif -- Import all relevant handler modules here. -- Don't forget to add new modules to your cabal file! import Handler.RootR import Handler.JournalR import Handler.RegisterR import Handler.SidebarR import Hledger.Web.WebOptions (WebOpts(..), defwebopts) import Hledger.Data (Journal, nulljournal) import Hledger.Read (readJournalFile) import Hledger.Utils (error') import Hledger.Cli.CliOptions (defcliopts, journalFilePathFromOpts) -- This line actually creates our YesodDispatch 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 :: WebOpts -> Journal -> AppConfig DefaultEnv Extra -> IO Application makeApplication opts j conf = do foundation <- makeFoundation conf opts writeIORef (appJournal foundation) j app <- toWaiAppPlain foundation return $ logWare app where logWare | development = logStdoutDev | serve_ opts = logStdout | otherwise = id makeFoundation :: AppConfig DefaultEnv Extra -> WebOpts -> IO App makeFoundation conf opts = do manager <- newManager #ifdef http_conduit_2 defaultManagerSettings #else def #endif s <- staticSite jref <- newIORef nulljournal return $ App conf s manager opts jref -- for yesod devel -- uses the journal specified by the LEDGER_FILE env var, or ~/.hledger.journal getApplicationDev :: IO (Int, Application) getApplicationDev = do f <- head `fmap` journalFilePathFromOpts defcliopts -- XXX head should be safe for now j <- either error' id `fmap` readJournalFile Nothing Nothing True f defaultDevelApp loader (makeApplication defwebopts j) where loader = Yesod.Default.Config.loadConfig (configSettings Development) { csParseExtra = parseExtra } hledger-web-1.2/Foundation.hs0000644000000000000000000004040513035510426014373 0ustar0000000000000000{-# LANGUAGE CPP, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, QuasiQuotes, TemplateHaskell, TypeFamilies, TypeSynonymInstances, FlexibleInstances #-} {- Define the web application's foundation, in the usual Yesod style. See a default Yesod app's comments for more details of each part. -} module Foundation where import Prelude #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Data.IORef import Yesod import Yesod.Static import Yesod.Default.Config #ifndef DEVELOPMENT import Yesod.Default.Util (addStaticContentExternal) #endif import Network.HTTP.Conduit (Manager) -- import qualified Settings import Settings.Development (development) import Settings.StaticFiles import Settings (staticRoot, widgetFile, Extra (..)) #ifndef DEVELOPMENT import Settings (staticDir) import Text.Jasmine (minifym) #endif import Text.Blaze.Html.Renderer.String (renderHtml) import Text.Hamlet (hamletFile) import Hledger.Web.WebOptions import Hledger.Data.Types -- import Hledger.Web.Settings -- import Hledger.Web.Settings.StaticFiles -- for addform import Data.List import Data.Maybe import Data.Text as Text (Text,pack,unpack) import Data.Time.Calendar #if BLAZE_HTML_0_4 import Text.Blaze (preEscapedString, Markup) #else import Text.Blaze (Markup) import Text.Blaze.Internal (preEscapedString) #endif import Text.JSON import Hledger.Data.Journal import Hledger.Query import Hledger hiding (is) import Hledger.Cli hiding (version) -- | 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 , getStatic :: Static -- ^ Settings for static file serving. , httpManager :: Manager -- , appOpts :: WebOpts , appJournal :: IORef 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://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") -- | A convenience alias. type AppRoute = Route App type Form x = Html -> MForm (HandlerT App IO) (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 _ = fmap Just $ defaultClientSessionBackend (120 * 60) ".hledger-web_client_session_key.aes" defaultLayout widget = do master <- getYesod lastmsg <- getMessage vd@VD{..} <- getViewData -- 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") pc <- widgetToPageContent $ do addStylesheet $ StaticR css_bootstrap_min_css -- load these things early, in HEAD: toWidgetHead [hamlet| " "<\\/script>" -- #236 listToJsonValueObjArrayStr as = preEscapedString $ escapeJSSpecialChars $ encode $ JSArray $ map (\a -> JSObject $ toJSObject [("value", showJSON a)]) as numpostings = 4 postingnums = [1..numpostings] filepaths = map fst $ jfiles j postingfields :: ViewData -> Int -> HtmlUrl AppRoute postingfields _ n = [hamlet|
|] where acctvar = "account" ++ show n acctph = "Account " ++ show n amtvar = "amount" ++ show n amtph = "Amount " ++ show n grpvar = "grp" ++ show n journalselect :: [FilePath] -> HtmlUrl AppRoute journalselect journalfilepaths = [hamlet| |] hledger-web-1.2/Handler/AddForm.hs0000644000000000000000000001247413035510426015163 0ustar0000000000000000{-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings, QuasiQuotes, RecordWildCards, TypeFamilies #-} -- | Add form data & handler. (The layout and js are defined in -- Foundation so that the add form can be in the default layout for -- all views.) module Handler.AddForm where import Import #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif import Control.Monad.State.Strict (evalStateT) import Data.Either (lefts,rights) import Data.List (sort) import qualified Data.List as L (head) -- qualified keeps dev & prod builds warning-free import Data.Text (append, pack, unpack) import qualified Data.Text as T import Data.Time.Calendar import Text.Megaparsec (digitChar, eof, some, string, runParser, ParseError, Dec) import Hledger.Utils import Hledger.Data hiding (num) import Hledger.Read import Hledger.Cli hiding (num) -- Part of the data required from the add form. -- Don't know how to handle the variable posting fields with yesod-form yet. data AddForm = AddForm { addFormDate :: Day , addFormDescription :: Maybe Text -- String -- , addFormPostings :: [(AccountName, String)] , addFormJournalFile :: Maybe Text -- FilePath } deriving Show postAddForm :: Handler Html postAddForm = do let showErrors errs = do -- error $ show errs -- XXX uncomment to prevent redirect for debugging setMessage [shamlet| Errors:
$forall e<-errs \#{e}
|] -- 1. process the fixed fields with yesod-form VD{..} <- getViewData let validateJournalFile :: Text -> Either FormMessage Text validateJournalFile f | unpack f `elem` journalFilePaths j = Right f | otherwise = Left $ MsgInvalidEntry $ pack "the selected journal file \"" `append` f `append` "\"is unknown" validateDate :: Text -> Handler (Either FormMessage Day) validateDate s = return $ case fixSmartDateStrEither' today $ T.pack $ strip $ unpack s of Right d -> Right d Left _ -> Left $ MsgInvalidEntry $ pack "could not parse date \"" `append` s `append` pack "\":" -- ++ show e) formresult <- runInputPostResult $ AddForm <$> ireq (checkMMap validateDate (pack . show) textField) "date" <*> iopt textField "description" <*> iopt (check validateJournalFile textField) "journal" ok <- case formresult of FormMissing -> showErrors ["there is no form data"::String] >> return False FormFailure errs -> showErrors errs >> return False FormSuccess dat -> do let AddForm{ addFormDate =date ,addFormDescription=mdesc ,addFormJournalFile=mjournalfile } = dat desc = maybe "" unpack mdesc journalfile = maybe (journalFilePath j) unpack mjournalfile -- 2. the fixed fields look good; now process the posting fields adhocly, -- getting either errors or a balanced transaction (params,_) <- runRequestBody let numberedParams s = reverse $ dropWhile (T.null . snd) $ reverse $ sort [ (n,v) | (k,v) <- params , let en = parsewith (paramnamep s) k :: Either (ParseError Char Dec) Int , isRight en , let Right n = en ] where paramnamep s = do {string s; n <- some digitChar; eof; return (read n :: Int)} acctparams = numberedParams "account" amtparams = numberedParams "amount" num = length acctparams paramErrs | num == 0 = ["at least one posting must be entered"] | map fst acctparams == [1..num] && map fst amtparams `elem` [[1..num], [1..num-1]] = [] | otherwise = ["the posting parameters are malformed"] eaccts = map (runParser (accountnamep <* eof) "" . textstrip . snd) acctparams eamts = map (runParser (evalStateT (amountp <* eof) mempty) "" . textstrip . snd) amtparams (accts, acctErrs) = (rights eaccts, map show $ lefts eaccts) (amts', amtErrs) = (rights eamts, map show $ lefts eamts) amts | length amts' == num = amts' | otherwise = amts' ++ [missingamt] errs = if not (null paramErrs) then paramErrs else (acctErrs ++ amtErrs) etxn | not $ null errs = Left errs | otherwise = either (\e -> Left [L.head $ lines e]) Right (balanceTransaction Nothing $ nulltransaction { tdate=date ,tdescription=T.pack desc ,tpostings=[nullposting{paccount=acct, pamount=Mixed [amt]} | (acct,amt) <- zip accts amts] }) case etxn of Left errs -> showErrors errs >> return False Right t -> do -- 3. all fields look good and form a balanced transaction; append it to the file liftIO $ do ensureJournalFileExists journalfile appendToJournalFileOrStdout journalfile $ showTransaction $ txnTieKnot -- XXX move into balanceTransaction t setMessage [shamlet|Transaction added.|] return True if ok then redirect JournalR else redirect (JournalR, [("add","1")]) hledger-web-1.2/Handler/Common.hs0000644000000000000000000002165013035510426015073 0ustar0000000000000000{-# LANGUAGE CPP, OverloadedStrings, QuasiQuotes, RecordWildCards #-} -- | Common page components and rendering helpers. -- For global page layout, see Application.hs. module Handler.Common where import Import -- import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar import System.FilePath (takeFileName) #if BLAZE_HTML_0_4 import Text.Blaze (preEscapedString) #else import Text.Blaze.Internal (preEscapedString) #endif import Text.Printf import Hledger.Utils import Hledger.Data import Hledger.Query import Hledger.Reports import Hledger.Cli.CliOptions import Hledger.Web.WebOptions ------------------------------------------------------------------------------- -- Common page layout -- | Standard hledger-web page layout. hledgerLayout :: ViewData -> String -> HtmlUrl AppRoute -> HandlerT App IO Html hledgerLayout vd title content = do defaultLayout $ do setTitle $ toHtml $ title ++ " - hledger-web" toWidget [hamlet| ^{topbar vd} ^{sidebar vd}
^{searchform vd} ^{content} |] where showmd = if showsidebar vd then "col-md-8" else "col-md-12" :: String showsm = if showsidebar vd then "col-sm-8" else "col-sm-12" :: String -- | Global toolbar/heading area. topbar :: ViewData -> HtmlUrl AppRoute topbar VD{..} = [hamlet|