{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, TemplateHaskell #-}
{-| 
A web-based UI.
-}

module Hledger.Cli.Commands.WebYesod
where

import Control.Concurrent -- (forkIO)
import qualified Network.Wai (Request(pathInfo))
import System.FilePath ((</>))
import System.IO.Storage (withStore, putValue, getValue)
import Text.Hamlet
import qualified Data.ByteString.Char8 as B
import Yesod

-- import Hledger.Cli.Commands.Add (journalAddTransaction)
import Hledger.Cli.Commands.Balance
import Hledger.Cli.Commands.Print
import Hledger.Cli.Commands.Register

import Hledger.Cli.Options hiding (value)
import Hledger.Cli.Utils
import Hledger.Data
#ifdef MAKE
import Paths_hledger_make (getDataFileName)
#else
import Paths_hledger (getDataFileName)
#endif


defhost = "localhost"
defport = 5000
browserstartdelay = 100000 -- microseconds
hledgerurl = "http://hledger.org"
manualurl = hledgerurl++"/MANUAL.html"

web :: [Opt] -> [String] -> Journal -> IO ()
web opts args j = do
  let host = fromMaybe defhost $ hostFromOpts opts
      port = fromMaybe defport $ portFromOpts opts
      url = printf "http://%s:%d" host port :: String
  unless (Debug `elem` opts) $ forkIO (browser url) >> return ()
  server url port opts args j

browser :: String -> IO ()
browser url = putStrLn "starting web browser" >> threadDelay browserstartdelay >> openBrowserOn url >> return ()

server :: String -> Int -> [Opt] -> [String] -> Journal -> IO ()
server url port opts args j = do
    printf "starting web server at %s\n" url
    fp <- getDataFileName "web"
    let app = HledgerWebApp{
               appOpts=opts
              ,appArgs=args
              ,appJournal=j
              ,appWebdir=fp
              ,appRoot=url
              }
    withStore "hledger" $ do -- IO ()
     putValue "hledger" "journal" j
     toWaiApp app >>= basicHandler port

data HledgerWebApp = HledgerWebApp {
      appOpts::[Opt]
     ,appArgs::[String]
     ,appJournal::Journal
     ,appWebdir::FilePath
     ,appRoot::String
     }

instance Yesod HledgerWebApp where approot = appRoot

mkYesod "HledgerWebApp" [$parseRoutes|
/             IndexPage        GET
/transactions TransactionsPage GET POST
/register     RegisterPage     GET
/balance      BalancePage      GET
/style.css    StyleCss         GET
/params       ParamsDebug      GET
|]

getParamsDebug = do
    r <- getRequest
    return $ RepHtml $ toContent $ show $ reqGetParams r

getIndexPage :: Handler HledgerWebApp ()
getIndexPage = redirect RedirectTemporary TransactionsPage

getTransactionsPage :: Handler HledgerWebApp RepHtml
getTransactionsPage = withLatestJournalRender (const showTransactions)

postTransactionsPage :: Handler HledgerWebApp RepHtml
postTransactionsPage = withLatestJournalRender (const showTransactions)

getRegisterPage :: Handler HledgerWebApp RepHtml
getRegisterPage = withLatestJournalRender showRegisterReport

getBalancePage :: Handler HledgerWebApp RepHtml
getBalancePage = withLatestJournalRender showBalanceReport

withLatestJournalRender :: ([Opt] -> FilterSpec -> Journal -> String) -> Handler HledgerWebApp RepHtml
withLatestJournalRender f = do
    app <- getYesod
    req <- getRequest
    params <- getParams
    t <- liftIO $ getCurrentLocalTime
    let as = params "a"
        ps = params "p"
        opts = appOpts app ++ [Period $ unwords ps]
        args = appArgs app ++ as
        fs = optsToFilterSpec opts args t
    j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
    (changed, j') <- liftIO $ journalReloadIfChanged opts j
    when changed $ liftIO $ putValue "hledger" "journal" j'
    let content = f opts fs j'
    return $ RepHtml $ toContent $ renderHamlet id $ template req as ps "" content
    -- hamletToRepHtml $ template "" s

getStyleCss :: Handler HledgerWebApp RepPlain
getStyleCss = do
    app <- getYesod
    let dir = appWebdir app
    s <- liftIO $ readFile $ dir </> "style.css"
    header "Content-Type" "text/css"
    return $ RepPlain $ toContent s

template :: Request -> [String] -> [String] -> String -> String -> Hamlet String
template req as ps t s = [$hamlet|
!!!
%html
 %head
  %meta!http-equiv=Content-Type!content=$string.metacontent$
  %link!rel=stylesheet!type=text/css!href=@stylesheet@!media=all
  %title $string.t$
 %body
  ^navbar'^
  #messages $string.msgs$
  #content
   %pre $string.s$
|]
 where msgs = intercalate ", " []
       navbar' = navbar req as ps
       stylesheet = "/style.css"
       metacontent = "text/html; charset=utf-8"

navbar :: Request -> [String] -> [String] -> Hamlet String
navbar req as ps = [$hamlet|
 #navbar
  %a#hledgerorglink!href=@hledgerurl@ hledger.org
  ^navlinks'^
  ^searchform'^
  %a#helplink!href=@manualurl@ help
|]
 where navlinks' = navlinks req as ps
       searchform' = searchform req as ps

navlinks :: Request -> [String] -> [String] -> Hamlet String
navlinks _ as ps = [$hamlet|
 #navlinks
  ^transactionslink^ | $
  ^registerlink^ | $
  ^balancelink^
|]
 where
  transactionslink = navlink "transactions"
  registerlink = navlink "register"
  balancelink = navlink "balance"
  navlink s = [$hamlet|%a.navlink!href=@u@ $string.s$|]
   where u = printf "../%s?a=%s&p=%s" s (intercalate "+" as) (intercalate "+" ps)

searchform :: Request -> [String] -> [String] -> Hamlet String
searchform req as ps = [$hamlet|
 %form#searchform!action=$string.action$
  search for: $
  %input!name=a!size=20!value=$string.a$
  ^ahelp^ $
  in reporting period: $
  %input!name=p!size=20!value=$string.p$
  ^phelp^ $
  %input!name=submit!type=submit!value=filter!style=display:none;
  ^resetlink^
|]
 where
  action=""
  a = intercalate "+" as
  p = intercalate "+" ps
  ahelp = helplink "filter-patterns"
  phelp = helplink "period-expressions"
  resetlink
   | null a && null p = [$hamlet||]
   | otherwise        = [$hamlet|%span#resetlink $
                                  %a!href=@u@ reset|]
   where u = B.unpack $ Network.Wai.pathInfo $ waiRequest req

helplink topic = [$hamlet|%a!href=@u@ ?|]
    where u = manualurl ++ if null topic then "" else '#':topic

{-
            
addform :: Hack.Env -> HSP XML
addform env = do
  today <- io $ liftM showDate $ getCurrentDay
  let inputs = Hack.Contrib.Request.inputs env
      date  = decodeString $ fromMaybe today $ lookup "date"  inputs
      desc  = decodeString $ fromMaybe "" $ lookup "desc"  inputs
  <div>
   <div id="addform">
   <form action="" method="POST">
    <table border="0">
      <tr>
        <td>
          Date: <input size="15" name="date" value=date /><% help "dates" %><% nbsp %>
          Description: <input size="35" name="desc" value=desc /><% nbsp %>
        </td>
      </tr>
      <% transactionfields 1 env %>
      <% transactionfields 2 env %>
      <tr id="addbuttonrow"><td><input type="submit" value="add transaction" 
      /><% help "file-format" %></td></tr>
    </table>
   </form>
   </div>
   <br clear="all" />
   </div>

transactionfields :: Int -> Hack.Env -> HSP XML
transactionfields n env = do
  let inputs = Hack.Contrib.Request.inputs env
      acct = decodeString $ fromMaybe "" $ lookup acctvar inputs
      amt  = decodeString $ fromMaybe "" $ lookup amtvar  inputs
  <tr>
    <td>
    <% nbsp %><% nbsp %>
      Account: <input size="35" name=acctvar value=acct /><% nbsp %>
      Amount: <input size="15" name=amtvar value=amt /><% nbsp %>
    </td>
   </tr>
    where
      numbered = (++ show n)
      acctvar = numbered "acct"
      amtvar = numbered "amt"

handleAddform :: Journal -> AppUnit
handleAddform j = do
  env <- getenv
  d <- io getCurrentDay
  t <- io getCurrentLocalTime
  handle t $ validate env d
  where
    validate :: Hack.Env -> Day -> Failing Transaction
    validate env today =
        let inputs = Hack.Contrib.Request.inputs env
            date  = decodeString $ fromMaybe "today" $ lookup "date"  inputs
            desc  = decodeString $ fromMaybe "" $ lookup "desc"  inputs
            acct1 = decodeString $ fromMaybe "" $ lookup "acct1" inputs
            amt1  = decodeString $ fromMaybe "" $ lookup "amt1"  inputs
            acct2 = decodeString $ fromMaybe "" $ lookup "acct2" inputs
            amt2  = decodeString $ fromMaybe "" $ lookup "amt2"  inputs
            validateDate ""  = ["missing date"]
            validateDate _   = []
            validateDesc ""  = ["missing description"]
            validateDesc _   = []
            validateAcct1 "" = ["missing account 1"]
            validateAcct1 _  = []
            validateAmt1 ""  = ["missing amount 1"]
            validateAmt1 _   = []
            validateAcct2 "" = ["missing account 2"]
            validateAcct2 _  = []
            validateAmt2 _   = []
            amt1' = either (const missingamt) id $ parse someamount "" amt1
            amt2' = either (const missingamt) id $ parse someamount "" amt2
            (date', dateparseerr) = case fixSmartDateStrEither today date of
                                      Right d -> (d, [])
                                      Left e -> ("1900/01/01", [showDateParseError e])
            t = Transaction {
                            tdate = parsedate date' -- date' must be parseable
                           ,teffectivedate=Nothing
                           ,tstatus=False
                           ,tcode=""
                           ,tdescription=desc
                           ,tcomment=""
                           ,tpostings=[
                             Posting False acct1 amt1' "" RegularPosting (Just t')
                            ,Posting False acct2 amt2' "" RegularPosting (Just t')
                            ]
                           ,tpreceding_comment_lines=""
                           }
            (t', balanceerr) = case balanceTransaction t of
                           Right t'' -> (t'', [])
                           Left e -> (t, [head $ lines e]) -- show just the error not the transaction
            errs = concat [
                    validateDate date
                   ,dateparseerr
                   ,validateDesc desc
                   ,validateAcct1 acct1
                   ,validateAmt1 amt1
                   ,validateAcct2 acct2
                   ,validateAmt2 amt2
                   ,balanceerr
                   ]
        in
        case null errs of
          False -> Failure errs
          True  -> Success t'

    handle :: LocalTime -> Failing Transaction -> AppUnit
    handle _ (Failure errs) = hsp errs addform
    handle ti (Success t)   = do
                    io $ journalAddTransaction j t >> reload j
                    ledgerpage [msg] j (showTransactions (optsToFilterSpec [] [] ti))
       where msg = printf "Added transaction:\n%s" (show t)

-}