{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} {-# OPTIONS_GHC -F -pgmFtrhsx #-} {-| A web-based UI. -} module Commands.Web where #if __GLASGOW_HASKELL__ <= 610 import Codec.Binary.UTF8.String (decodeString) #endif import Control.Applicative.Error (Failing(Success,Failure)) import Control.Concurrent import Control.Monad.Reader (ask) import Data.IORef (newIORef, atomicModifyIORef) import Network.HTTP (urlEncode, urlDecode) import System.Directory (getModificationTime) import System.IO.Storage (withStore, putValue, getValue) import System.Time (ClockTime, getClockTime, diffClockTimes, TimeDiff(TimeDiff)) import Text.ParserCombinators.Parsec (parse) import Hack.Contrib.Constants (_TextHtmlUTF8) import Hack.Contrib.Response (set_content_type) import qualified Hack (Env, http) import qualified Hack.Contrib.Request (inputs, params, path) import qualified Hack.Contrib.Response (redirect) #ifdef WEBHAPPSTACK import System.Process (readProcess) import Hack.Handler.Happstack (runWithConfig,ServerConf(ServerConf)) #else import Hack.Handler.SimpleServer (run) #endif import Network.Loli (loli, io, get, post, html, text, public) import Network.Loli.Type (AppUnit) import Network.Loli.Utils (update) import HSP hiding (Request,catch) import qualified HSP (Request(..)) import HSP.HTML (renderAsHTML) import Commands.Add (ledgerAddTransaction) import Commands.Balance import Commands.Histogram import Commands.Print import Commands.Register import Ledger import Options hiding (value) #ifdef MAKE import Paths_hledger_make (getDataFileName) #else import Paths_hledger (getDataFileName) #endif import Utils (openBrowserOn) -- import Debug.Trace -- strace :: Show a => a -> a -- strace a = trace (show a) a tcpport = 5000 :: Int homeurl = printf "http://localhost:%d/" tcpport browserdelay = 100000 -- microseconds web :: [Opt] -> [String] -> Ledger -> IO () web opts args l = do unless (Debug `elem` opts) $ forkIO browser >> return () server opts args l browser :: IO () browser = putStrLn "starting web browser" >> threadDelay browserdelay >> openBrowserOn homeurl >> return () server :: [Opt] -> [String] -> Ledger -> IO () server opts args l = -- server initialisation withStore "hledger" $ do -- IO () printf "starting web server on port %d\n" tcpport t <- getCurrentLocalTime webfiles <- getDataFileName "web" putValue "hledger" "ledger" l #ifdef WEBHAPPSTACK hostname <- readProcess "hostname" [] "" `catch` \_ -> return "hostname" runWithConfig (ServerConf tcpport hostname) $ -- (Env -> IO Response) -> IO () #else run tcpport $ -- (Env -> IO Response) -> IO () #endif \env -> do -- IO Response -- general request handler let a = intercalate "+" $ reqparam env "a" p = intercalate "+" $ reqparam env "p" opts' = opts ++ [Period p] args' = args ++ (map urlDecode $ words a) l' <- fromJust `fmap` getValue "hledger" "ledger" l'' <- reloadIfChanged opts' args' l' -- declare path-specific request handlers let command :: [String] -> ([Opt] -> FilterSpec -> Ledger -> String) -> AppUnit command msgs f = string msgs $ f opts' (optsToFilterSpec opts' args' t) l'' (loli $ -- State Loli () -> (Env -> IO Response) do get "/balance" $ command [] showBalanceReport -- String -> ReaderT Env (StateT Response IO) () -> State Loli () get "/register" $ command [] showRegisterReport get "/histogram" $ command [] showHistogram get "/transactions" $ ledgerpage [] l'' (showTransactions (optsToFilterSpec opts' args' t)) post "/transactions" $ handleAddform l'' get "/env" $ getenv >>= (text . show) get "/params" $ getenv >>= (text . show . Hack.Contrib.Request.params) get "/inputs" $ getenv >>= (text . show . Hack.Contrib.Request.inputs) public (Just webfiles) ["/style.css"] get "/" $ redirect ("transactions") Nothing ) env getenv = ask response = update redirect u c = response $ Hack.Contrib.Response.redirect u c reqparam :: Hack.Env -> String -> [String] #if __GLASGOW_HASKELL__ <= 610 reqparam env p = map snd $ filter ((==p).fst) $ Hack.Contrib.Request.params env #else reqparam env p = map (decodeString.snd) $ filter ((==p).fst) $ Hack.Contrib.Request.params env #endif ledgerFileModifiedTime :: Ledger -> IO ClockTime ledgerFileModifiedTime l | null path = getClockTime | otherwise = getModificationTime path `Prelude.catch` \_ -> getClockTime where path = filepath $ journal l ledgerFileReadTime :: Ledger -> ClockTime ledgerFileReadTime l = filereadtime $ journal l reload :: Ledger -> IO Ledger reload l = do l' <- readLedger (filepath $ journal l) putValue "hledger" "ledger" l' return l' reloadIfChanged :: [Opt] -> [String] -> Ledger -> IO Ledger reloadIfChanged opts _ l = do tmod <- ledgerFileModifiedTime l let tread = ledgerFileReadTime l newer = diffClockTimes tmod tread > (TimeDiff 0 0 0 0 0 0 0) -- when (Debug `elem` opts) $ printf "checking file, last modified %s, last read %s, %s\n" (show tmod) (show tread) (show newer) if newer then do when (Verbose `elem` opts) $ printf "%s has changed, reloading\n" (filepath $ journal l) reload l else return l -- refilter :: [Opt] -> [String] -> Ledger -> LocalTime -> IO Ledger -- refilter opts args l t = return $ filterAndCacheLedgerWithOpts opts args t (jtext $ journal l) (journal l) ledgerpage :: [String] -> Ledger -> (Ledger -> String) -> AppUnit ledgerpage msgs l f = do env <- getenv l' <- io $ reloadIfChanged [] [] l hsp msgs $ const
<% f l' %>
<% s %>-- | A loli directive to serve a hsp template wrapped in the hledger web -- layout. The hack environment is passed in to every hsp template as an -- argument, since I don't see how to get it within the hsp monad. -- A list of messages is also passed, eg for form errors. hsp :: [String] -> (Hack.Env -> HSP XML) -> AppUnit hsp msgs f = do env <- getenv let contenthsp = f env pagehsp = hledgerpage env msgs title contenthsp html =<< (io $ do hspenv <- hackEnvToHspEnv env (_,xml) <- runHSP html4Strict pagehsp hspenv return $ addDoctype $ renderAsHTML xml) response $ set_content_type _TextHtmlUTF8 where title = "" addDoctype = ("\n" ++) hackEnvToHspEnv :: Hack.Env -> IO HSPEnv hackEnvToHspEnv env = do x <- newIORef 0 let req = HSP.Request (reqparam env) (Hack.http env) num = NumberGen (atomicModifyIORef x (\a -> (a+1,a))) return $ HSPEnv req num -- htmlToHsp :: Html -> HSP XML -- htmlToHsp h = return $ cdata $ showHtml h -- views hledgerpage :: Hack.Env -> [String] -> String -> HSP XML -> HSP XML hledgerpage env msgs title content =