Index.hs

{-# LANGUAGE ScopedTypeVariables #-}
module Bein.Web.Pages.Index where

import Bein.Web.Elements
import Bein.Web.Types
import Bein.Web.Pages.Common
import Data.Time
import System.Locale
import Bein.Web.Commands
import Happstack.Server
import Control.Monad.Trans
import qualified Data.Map as M
import Data.List (intersperse)
import Bein.Web.Pages.Login

index :: BeinServerPart Response
index = authenticated $ page Nothing HideHome (const $ lift $ indexHeader <> objectList) ()

indexHeader :: BeinServerPart Html
indexHeader = thedivM <! [identifier "object-list-header"] =<<: [
                      paragraphM <! [identifier "object-list-new-line"] =<<: [
                         headerAnchor "new/execution" "New Execution",
                         headerAnchor "new/program" "New Program",
                         headerAnchor "new/file" "New File" ]]
  where headerAnchor :: HTML a => String -> a -> BeinServerPart Html
        headerAnchor hr txt = fullUrl hr >>= \u -> anchorM <! [href u] =<< html txt
        
objectList :: BeinServerPart Html
objectList = do
  st :: Maybe Int <- getDataFn $ lookRead "start"
  cn :: Maybe Int <- getDataFn $ lookRead "display"
  user <- asksUser
  objs <- lift $ getObjects user st cn
  thedivM <! [identifier "object-list"] =<<: map compactDisplay objs

compactDisplay :: BeinObject -> BeinServerPart Html
compactDisplay obj = thedivM <! [theclass "compact"] =<< leftPane obj <> rightPane obj
  
leftPane :: BeinObject -> BeinServerPart Html
leftPane obj = do
  displayUrl <- fullUrl ("/" ++ show (objId obj))
  editUrl <- fullUrl ("/" ++ show (objId obj) ++ "/edit")
  let h = objHeader obj
  thedivM <! [theclass "left"] =<<: [ 
    paragraphM <! [theclass "title"] =<< anchorM <! [href displayUrl] << objectTag obj,
    paragraphM << (userName (owner h) ++ "/" ++ groupName (group h) ++ " " ++ formatPermissions (gr h) (gw h) (wr h) (ww h)),
    paragraphM << ("Last modified " ++ formatTime defaultTimeLocale "%F %R" (lastModified h)),
    paragraphM << ("Created " ++ formatTime defaultTimeLocale "%F %R" (created h)), 
    paragraphM =<< anchorM <! [href editUrl] << "Edit" ]
        
rightPane :: BeinObject -> BeinServerPart Html
rightPane obj = thedivM <! [theclass "right"] =<<: [
  paragraphM <! [theclass "notes"] << (notes $ objHeader obj),
  compactBody obj ]

compactBody :: BeinObject -> BeinServerPart Html
compactBody obj = case objBody obj of
  Nothing -> paragraphM << ("Future of type " ++ show (objType (objHeader obj)))
  Just f@FileBody{} -> paragraphM << ("File " ++ userFilename f)
  Just p@ProgramBody{} -> mconcatM [
    paragraphM << (show (language p) ++ " script beginning:"),
    preM << (take 300 (script p) ++ "..."),
    paragraphM =<< strongM << "Inputs: " <> brM <> mconcatM (intersperse brM (map (html . showInput) $ M.toList (programInputs p))),
    paragraphM =<< strongM << "Outputs: " <> brM <> mconcatM (intersperse brM (map (html . ("file "++)) $ M.keys (programOutputs p))) ]
    where showInput (k,v) = case v of
            InputSequence -> "sequence " ++ k
            InputFile -> "file " ++ k
            InputString -> "string " ++ k
            InputNumber -> "number " ++ k
  Just x@ExecutionBody{} -> mconcatM [ 
    paragraphM << showStatus (status x) (program x),
    paragraphM =<< strongM << "Inputs: " <> brM <> mconcatM (intersperse brM (map (html . showInput) $ M.toList (executionInputs x))),
    paragraphM =<< strongM << "Outputs: " <> brM <> mconcatM (intersperse brM (map (html . showOutput) $ M.toList (executionOutputs x))) ]
    where showStatus _ Nothing = "Execution with no program set."
          showStatus Waiting (Just p) = "Waiting execution of program " ++ objectTag p
          showStatus Running (Just p) = "Running execution of program " ++ objectTag p
          showStatus Complete (Just p) = "Completed execution of program " ++ objectTag p
          showStatus Failed (Just p) = "Failed execution of program " ++ objectTag p
          showStatus (DependencyFailed v) (Just p) = "Execution of program " ++ objectTag p ++ " with failed dependency " ++ show v ++ "."
          showInput :: (String,ExecutionInput) -> String
          showInput (lbl,ExecutionStringInput str) = lbl ++ " (string) ← " ++ (maybe "(undefined)" show str)
          showInput (lbl,ExecutionNumberInput n) = lbl ++ " (number) ← " ++ (maybe "(undefined)" show n)
          showInput (lbl,ExecutionObjectInput tobj) = lbl ++ " (file) ← " ++ (maybe "(undefined)" objectTag tobj)
          showOutput (lbl,ExecutionFileOutput tobj) = lbl ++ " (file) → " ++ objectTag tobj