{-| 
A happs-based web UI for hledger.
-}

module WebCommand
where
import qualified Data.Map as M
import Data.Map ((!))
import Data.Time.Clock
import Data.Time.Format
import System.Locale
import Control.Concurrent
import qualified Data.ByteString.Lazy.Char8 as B
-- import qualified Text.StringTemplate as T
-- import Codec.Compression.GZip (compress)
-- import Data.ByteString.UTF8 (fromString)
import HAppS.Server
import System.Cmd (system)
import System.Info (os)
import System.Exit

import Ledger
import Options
import BalanceCommand
import RegisterCommand
import PrintCommand


-- | The application state when running the ui command.
data AppState = AppState {
     aw :: Int                   -- ^ window width
    ,ah :: Int                   -- ^ window height
    ,amsg :: String              -- ^ status message
    ,aopts :: [Opt]              -- ^ command-line opts
    ,aargs :: [String]           -- ^ command-line args
    ,aledger :: Ledger           -- ^ parsed ledger
    ,abuf :: [String]            -- ^ lines of the current buffered view
                                -- ^ never null, head is current location
    } deriving (Show)

tcpport = 5000

web :: [Opt] -> [String] -> Ledger -> IO ()
web opts args l = do
  putStrLn $ printf "starting web server on port %d" tcpport
  tid <- forkIO $ simpleHTTP nullConf{port=tcpport} $ handlers opts args l
  putStrLn "starting web browser"
  browseUrl $ printf "http://localhost:%s/print" (show tcpport)
  waitForTermination
  putStrLn "shutting down..."
  killThread tid
  putStrLn "shutdown complete"

template  = "<div align=center style=width:100%%>" ++
            " <a href=print>ledger</a>" ++
            " | <a href=register>register</a>" ++
            " | <a href=balance>balance</a>" ++
            "</div>" ++
            "<pre>%s</pre>"

type Handler = ServerPart Response

handlers :: [Opt] -> [String] -> Ledger -> [Handler]
handlers opts args l = 
        [
          dir "print" [withRequest $ \r -> respond $ printreport r]
        , dir "register" [withRequest $ \r -> respond $ registerreport r]
        , dir "balance" [withRequest $ \r -> respond $ balancereport r]
        ]
    where
      respond = ok . setContentType "text/html" . toResponse . (printf template :: String -> String)
      printreport r = showEntries opts (pats r ++ args) l
      registerreport r = showRegisterReport opts (pats r ++ args) l
      balancereport r = showBalanceReport (opts++[SubTotal]) (pats r ++ args) l
      pats r = as -- ++ if null ds then [] else ("--":ds)
               where (as,ds) = (queryValues "a" r, queryValues "d" r)

queryValues :: String -> Request -> [String]
queryValues q r = map (B.unpack . inputValue . snd) $ filter ((==q).fst) $ rqInputs r

queryValue :: String -> Request -> Maybe String
queryValue q r = case filter ((==q).fst) $ rqInputs r of
                   [] -> Nothing
                   is -> Just $ B.unpack $ inputValue $ snd $ head is

-- | Attempt to open a web browser on the given url, all platforms.
browseUrl :: String -> IO ExitCode
browseUrl u = trybrowsers browsers u
    where
      trybrowsers (b:bs) u = do
        e <- system $ printf "%s %s" b u
        case e of
          ExitSuccess -> return ExitSuccess
          ExitFailure _ -> trybrowsers bs u
      trybrowsers [] u = do
        putStrLn $ printf "Sorry, I could not start a browser (tried: %s)" $ intercalate ", " browsers
        putStrLn $ printf "Please open your browser and visit %s" u
        return $ ExitFailure 127
      browsers | os=="darwin"  = ["open -a firefox", "open"]
               | os=="mingw32" = ["firefox","safari","opera","iexplore"]
               | otherwise     = ["firefox","sensible-browser"]
    -- jeffz: write a ffi binding for it using the Win32 package as a basis
    -- start by adding System/Win32/Shell.hsc and follow the style of any
    -- other module in that directory for types, headers, error handling and
    -- what not.
    -- ::ShellExecute(NULL, "open", "www.somepage.com", NULL, NULL, SW_SHOWNORMAL);
    -- ::ShellExecute(NULL, "open", "firefox.exe", "www.somepage.com" NULL, SW_SHOWNORMAL);

withExpiresHeaders :: ServerPart Response -> ServerPart Response
withExpiresHeaders sp = require getCacheTime $ \t -> [liftM (setHeader "Expires" $ formatDateTime "%a, %d %b %Y %T GMT" t) sp]

getCacheTime :: IO (Maybe UTCTime)
getCacheTime = getCurrentTime >>= (return . Just . addMinutes 360)

addMinutes :: Int -> UTCTime -> UTCTime
addMinutes n = addUTCTime (fromIntegral n) 

formatDateTime :: String -> UTCTime -> String
formatDateTime = formatTime defaultTimeLocale

setContentType :: String -> Response -> Response
setContentType = setHeader "Content-Type"

setFilename :: String -> Response -> Response
setFilename = setHeader "Content-Disposition" . \fname -> "attachment: filename=\"" ++ fname ++ "\""

-- gzipBinary :: Response -> Response
-- gzipBinary r@(Response {rsBody = b}) =  setHeader "Content-Encoding" "gzip" $ r {rsBody = compress b}

-- acceptsZip :: Request -> Bool
-- acceptsZip req = isJust $ M.lookup (fromString "accept-encoding") (rqHeaders req)