Advise-me-0.1: app/AdviseMeAdmin.hs

{-# LANGUAGE OverloadedStrings #-}
{-|
Module      : Main
Description : Produces the CGI binary to the admin module.

Note that we are using an ad-hoc solution to CSV output. Use the @cassava@
package once we need real CSV support.
-}
module Main (main) where

import Data.Monoid ( (<>) )
import Data.Char
import Data.List (sort, isSuffixOf, intersperse, foldl', intersperse)
import Data.Maybe
import Data.String
import Data.Time (formatTime, defaultTimeLocale, UTCTime)
import Control.Monad
import Control.Exception
import Control.Applicative ((<|>))
import Database.HDBC.Sqlite3
import Ideas.Text.HTML hiding (table)
import Ideas.Text.HTML.W3CSS hiding (tag, table, select, input, content)
import Ideas.Text.XML
import qualified Ideas.Text.XML as XML
import Ideas.Utils.Prelude (readM)
import Network.HTTP.Types
import Network.Wai
import System.Directory
import qualified Data.Map as M
import qualified Data.ByteString.Char8 as B
import qualified Ideas.Text.HTML.W3CSS as W3
import qualified Network.Wai.Handler.CGI as CGI

import Bayes.StudentReport (StudentReport, toReport, Competence(..), competences, Translation(..) )
import Bayes.Evidence
import Bayes.Network
import Bayes.NetworkReader
import Bayes.Probability
import Bayes.SVG
import Database.Data
import Util.TableData
import Util.List (orderBy)
import qualified Recognize.Data.MathStoryProblem as MSP
import Main.Tasks ( findTaskFuzzy, taskNetwork )
import Util.String ( percentage, (//) )
import Database.Priors ( Priors(Priors), Prior(Prior), calculatePriors )

data Env = Env
   { binary          :: FilePath
   , database        :: FilePath
   , connection      :: Connection
   , pageType        :: PageType
   }

data Resource
   = HTMLFile HTMLBuilder
   | CSVFile String
   | XMLFile String String

data FileType
   = HTML
   | CSV
   deriving (Show, Read)

data PageType
   = Students
   | Tasks
   | Options
   | Report Bool
   | ModelPage String Int
   | Task String
   | StudentModelsPage FileType
   | SingleRequest Int


main :: IO ()
main = CGI.run app


app :: Application
app req respond = do
   env <- makeEnv req
   resource <- (`catch` errorHandler) $ case pageType env of
      StudentModelsPage ft -> studentModelsPage ft env
      Students             -> studentsPage env
      Report ev            -> reportPage ev env
      Tasks                -> tasksPage env
      ModelPage sid i      -> modelPage env sid i
      Task tid             -> taskPage env tid
      Options              -> optionsPage env
      SingleRequest i      -> requestPage env i
   respond $ case resource of
      HTMLFile html -> responseLBS status200
         [ ("Content-Type", "text/html")
         , ("Access-Control-Allow-Origin", "*") ]
         (fromString $ showHTML $ stdPage env html)
      CSVFile csv -> responseLBS status200
         [ ("Content-Type", "text/plain")
         , ("Access-Control-Allow-Origin", "*")
         , ("Content-Disposition"
           , fromString $ "attachment; filename=\"summary-" ++ database env ++ ".csv\"")
         ]
         (fromString csv)
      XMLFile name xml -> responseLBS status200
         [ ("Content-Type", "text/xml")
         , ("Access-Control-Allow-Origin", "*")
         , ("Content-Disposition"
         , fromString $ "attachment; filename=\"" ++ takeWhile (/='.') (database env) ++ "+" ++ name ++ ".xml\"")
         ]
         (fromString xml)


makeEnv :: Request -> IO Env
makeEnv req = do

   dbs <- findDatabases
   let db = fromMaybe "" $ param "database" <|> listToMaybe dbs
   conn <- if db `elem` dbs
      then connectSqlite3 db
      else return $ error ("Database " ++ db ++ " does not exist.")

   return Env
      { binary = cgiScript
      , database = db
      , connection = conn
      , pageType = case paramString "page" of
         "tasks" -> Tasks
         "options" -> Options
         "students" -> Students
         "studentmodels" -> StudentModelsPage (paramTyped HTML "filetype")
         "task" -> Task (paramString "taskid")
         "model" -> ModelPage (paramString "studentid") (paramTyped 1 "i")
         "report" -> Report (paramFlag "evidence")
         "request" -> SingleRequest (paramTyped 0 "i")
         _ -> Students
      }

   where

   cgiScript :: String -- Is this safe?
   cgiScript = maybe "" B.unpack . lookup "CGI-Script-Name" . requestHeaders $ req

   query :: Query
   query = queryString req

   param :: B.ByteString -> Maybe String
   param = fmap (safeString . maybe "" B.unpack) . flip lookup query

   paramFlag :: B.ByteString -> Bool
   paramFlag = maybe False (const True) . flip lookup query

   paramString :: B.ByteString -> String
   paramString = fromMaybe "" . param

   paramTyped :: Read a => a -> B.ByteString -> a
   paramTyped def = fromMaybe def . (param >=> readM)

   safeString :: String -> String
   safeString = filter (\c -> isAlphaNum c || c `elem` ['.','-','_'])


findDatabases :: IO [FilePath]
findDatabases = sort . filter (".db" `isSuffixOf`) <$> getDirectoryContents "."

-- | Find the network file associated with a task ID.
findNetwork :: TaskID -> IO FilePath
findNetwork tID = do
   MSP.Task t <- findTaskFuzzy tID
   maybe (error "Could not find network") return $ MSP.networkFile t

urlFor :: Env -> String
urlFor env = binary env ++ B.unpack (renderSimpleQuery True params)

   where
   params :: SimpleQuery
   params = ("database", fromString $ database env) : case pageType env of
      Students             -> [("page", "students")]
      StudentModelsPage ft -> [("page", "studentmodels"), ("filetype", fromString $ show ft)]
      Tasks                -> [("page", "tasks")]
      Options              -> [("page", "options")]
      ModelPage sID i      -> [("page", "model"), ("studentid", fromString sID), ("i", fromString $ show i)]
      Report showEvidence  -> [("page", "report"), ("evidence", "1")]
      Task tID             -> [("page", "task"), ("taskid", fromString tID)]
      SingleRequest i      -> [("page", "request"), ("i", fromString $ show i)] 




-------------------------------------------------------------------------------
-- * HTML

stdPage :: Env -> HTMLBuilder -> HTMLPage
stdPage env html = addCSS "https://www.w3schools.com/w3css/4/w3.css" $
                   htmlPage "IDEAS Log" $
   W3.container (background Indigo $ mconcat
           [ mkItem Students "Students"
           , mkItem Tasks    "Tasks"
           , mkItem (StudentModelsPage HTML)  "Student models"
           , mkItem (Report False) "All requests"
           , mkItem Options  "Options"
           ]) <>
   W3.container html
 where
   mkItem tp s = button (urlFor env {pageType = tp}) (string s)

errorHandler :: SomeException -> IO Resource
errorHandler = return . HTMLFile . panel . textColor Red . text

table :: Bool -> [[HTMLBuilder]] -> HTMLBuilder
table hasHeader = tableAll . mconcat . zipWith f (hasHeader : repeat False)
 where
   f header = tag "tr" . mconcat . map make
    where
      make | header    = tag "th"
           | otherwise = tag "td"

pageNavBar :: Int -> Env -> (Int -> PageType) -> Int -> HTMLBuilder
pageNavBar nr env pageFor lastPage = fontSize Small $ mconcat $
   [ pageLinkWith 1 False (string "previous")] ++
   map pageLink [start .. end] ++
   [pageLinkWith lastPage False (string "next")]
 where
   start = (nr-5) `max` 1
   end   = (start+10) `min` lastPage

   pageLink i = pageLinkWith i (i==nr) (text i)
   pageLinkWith i b a =
      button (urlFor env {pageType = pageFor i}) ((if b then background Indigo mempty else mempty) <> a)


-- | Create a HTML download button.
htmlDownloadCSV :: Env -> HTMLBuilder
htmlDownloadCSV env = button
   (urlFor env {pageType = StudentModelsPage CSV})
   (rounded XL . border . W3.background W3.Blue $ string "download CSV")

-- | Create a prettyprinted HTML link to a student ID.
htmlStudentID :: Env -> String -> HTMLBuilder
htmlStudentID env sID = fontSize Small . bold $ link (urlFor (env {pageType = ModelPage sID 1})) (string sID)

-- | Create a prettyprinted HTML link to a task ID.
htmlTaskID :: Env -> String -> HTMLBuilder
htmlTaskID env tID = fontSize Small . bold $ link (urlFor env {pageType = Task tID}) (string tID)

-- | Create a prettyprinted HTML label.
htmlLabel :: String -> HTMLBuilder
htmlLabel = fontSize Small . bold . string

-- | Create a prettyprinted percentage.
htmlPercentage :: Double -> HTMLBuilder
htmlPercentage = string . percentage 1

-- | Prettyprint information about strategy.
htmlStrategy :: Evidence -> HTMLBuilder
htmlStrategy ev = number ev <> br <> strategies ev

   where
   number :: Evidence -> HTMLBuilder
   number = (<> string " evidence") . bold . text . length . fromEvidence

   strategies :: Evidence -> HTMLBuilder
   strategies
      = spanClass "strategies"
      . mconcat
      . intersperse br
      . map (string . uncurry (state2label taskNetwork))
      . filter (("Strat" `isSuffixOf`) . fst)
      . hardEvidence


-- ** HTML pages

reportPage :: Bool -> Env -> IO Resource
reportPage showEvidence env = do
   allEntries <- allRecords (connection env)
   humanAssessments <- allHumanAssessments (connection env)
   return . HTMLFile . mconcat . intersperse hr . flip map (grouped allEntries) $
      \(sID, entries) ->
         h2 sID <> (mconcat . intersperse br . map (htmlEntry env humanAssessments showEvidence) $ entries)

   where
   grouped = orderBy ((! "studentid") :: SqlRecord -> String)


modelPage :: Env -> String -> Int -> IO Resource
modelPage env studentid i = do
   entries <- studentRecords (connection env) studentid
   let n = length entries
   let entry = entries !! ((i `min` n) - 1)

   let sID = entry ! "studentid"
       tID = entry ! "taskid"
       ev = entry ! "evidence" :: Evidence
       sm = entry ! "studentmodel" :: StudentModel
       inputXML = entry ! "input"
       time = entry ! "time" :: UTCTime

   (l1, nw1) <- readNetwork "networks/StudentModel.xdsl"
   (l2, nw2) <- findNetwork (entry ! "taskid") >>= readNetwork
   report <- toReport sID "en" sm

   return $ HTMLFile $
      panel (button (urlFor env { pageType = ModelPage studentid (i+1 `min` n)}) (rounded XL $ border $ marginPos CenterRight $ string "Next")
         <> pageNavBar i env (ModelPage studentid) n <>
         tag "div" (right $ string (formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" time))) <>
      h3 ("Inputs for " ++ tID) <>
      mconcat (map (uncurry inputBox) (inputHTMLs inputXML)) <>
      bold (string "Evidence: ") <> text ev <> br <>
      h3 ("Report for " ++ sID) <>
      htmlReport report <>
      h3 ("User model for " ++ sID) <>
      networkToSVG Just l1 (sm `trans` nw1) <>
      h3 ("Task model for " ++ tID) <>
      networkToSVG Just l2 (ev `trans` nw2)


-- | Create a table representing the student report.
htmlReport :: StudentReport -> HTMLBuilder
htmlReport report = W3.tableAll . mconcat $
      ( tag "tr" . mconcat . map (tag "th") $ [string "Competence", string "Value", string "Visualisation"] ) : 
      [ htmlCompetence 0 c | c <- competences report ]

   where 

   htmlCompetence :: Int -> Competence -> HTMLBuilder
   htmlCompetence i c = mconcat $ 
      ( tag "tr" . mconcat . map (tag "td") $
            [ spacer i <> (translationLabel $ skillText c), maybe (string "?") htmlPercentage $ skillValue c, skillBar $ (maybe 0.5 id (skillValue c) - 0.5) * 2]
      ) :
      [ htmlCompetence (i+1) c' | c' <- subskills c ]

   spacer :: Int -> HTMLBuilder
   spacer i = tag "span" ("style" .=. ("margin-left:" ++ show (i * 30) ++ "px"))

   skillBar :: Double -> HTMLBuilder
   skillBar d | d < 0  = wrap $ tag "div" ("style" .=. ("display:inline-block;height:20px;background-color:red;border-right:1px solid black;margin-left:" ++ show (maxwidth-width) ++ "px;width:" ++ show width ++ "px;margin-right:"++ show maxwidth ++"px"))
              | d >= 0 = wrap $ tag "div" ("style" .=. ("display:inline-block;height:20px;background-color:green;border-left:1px solid black;margin-left:" ++ show maxwidth ++ "px;width:" ++ show width ++ "px;margin-right:"++ show (maxwidth-width) ++"px"))
      
      where
      maxwidth = 150 :: Integer
      width = round $ 1 + abs d * fromIntegral maxwidth
      wrap x = tag "div" ("style" .=. "float:left;border:1px solid black;" <> x)


-- | Create a labelled 'input' box.
inputBox :: String -> HTMLBuilder -> HTMLBuilder
inputBox lbl html =
   tag "div" $ background LightGray $ barPos CenterLeft $ panel $
      (tag "div" $ background Indigo $ right $ styleA "position:relative;right:-16px;font-size:0.8em" <> space <> string lbl <> space) <>
      (html)


-- | Extract the inputIDs and input texts from an entry's XML.
inputHTMLs :: XML.XML -> [(InputID, HTMLBuilder)]
inputHTMLs = map (fmap $ XML.tag "pre"
                       . mconcat
                       . (("style" XML..=. "white-space: pre-wrap"):)
                       . map (either XML.string XML.builder)
                       . content
                       )
           . fromMaybe []
           . collectInputs


-- | Create a HTML element that represents one request. The request is
-- annotated with the "original" request numbers and can be downloaded as XML.
htmlEntry :: Env -> M.Map (StudentID, TaskID) [(NodeID, Maybe String, Maybe String)] -> Bool -> SqlRecord -> HTMLBuilder
htmlEntry env humanAssessments showEvidence record = 
   bold (string $ record ! "taskid") <> 
   string (" (request: " ++ findWithDefault "unknown" "original" record ++ ")") <> br <>
   (if showEvidence then tag "div" $ small (bold (string "evidence") <> string ": " <> text (record ! "evidence" :: Evidence) <> mistakesHTML) else mempty) <>
   mconcat (map (uncurry inputBox) (inputHTMLs $ record ! "input")) <>
   button
      (urlFor env {pageType = SingleRequest (record ! "rowid")})
      (rounded XL . border . W3.background W3.Blue $ string "download XML") <> br
   
   where
   mistakes = M.lookup (record ! "studentid", record ! "taskid") humanAssessments

   mistakesHTML = maybe
      (tag "div" $ string "(no human assessment)")
      (tag "div" . mconcat . intersperse (string ", ") . map mistaketoHTML)
      mistakes

   mistaketoHTML (nID, Just x, Nothing) = tag "span" $ textColor Blue (string nID <> string " should be " <> string x)
   mistaketoHTML (nID, x, _) = tag "span" $ textColor Red (string nID <> string " should be " <> maybe (string "empty") string x)


requestPage :: Env -> Int -> IO Resource
requestPage env i = do
   record <- fromJust <$> recordN (connection env) i 
   return $ XMLFile (record ! "original") (record ! "input")


taskPage :: Env -> String -> IO Resource
taskPage env tID = do
   (l, nw) <- findNetwork tID >>= readNetwork
   records <- taskRecords (connection env) tID
   count <- countStudents (connection env)
   let tbl = makeTable . calculatePriors . records2table $ records
   --let tbl = makeTable nw records

   return $ HTMLFile $
         h1 ("Evidence for " ++ tID) <>
          -- Note: We assume that every student sends at most one request per task
         string (length records `perc` count) <>
         string " of students have sent a request for this task." <>
         htmlTable (italic . string) (bold . string) string tbl <>
         h1 "Task model" <>
         networkToSVG (const Nothing) l nw <>
         h1 "Inputs" <>
         inputBoxes (getInputs records)

   where

   -- | Obtain inputs for all students, grouped by input ID.
   getInputs :: [SqlRecord] -> M.Map InputID [(StudentID, HTMLBuilder)]
   getInputs = flip foldl' mempty $ \m r ->
      foldl'
         (\m' (iID, txt) -> M.insertWith (++) iID [(r ! "studentid", txt)] m')
         m
         (inputHTMLs (r ! "input"))


   -- | Create input boxes for all input groups.
   inputBoxes :: M.Map InputID [(StudentID, XMLBuilder)] -> HTMLBuilder
   inputBoxes = flip M.foldrWithKey mempty $ \inputID list accumulator ->
      h3 ("Inputs for " ++ inputID) <>
      mconcat (map (uncurry inputBox) list) <>
      accumulator

   perc :: (Show a, Show b, Real a, Real b) => a -> b -> String
   perc x y = show x ++ " of " ++ show y ++ " (" ++ percentage 1 (x // y) ++ ")"

   makeTable :: Priors -> Table String String String
   makeTable (Priors mapping)
      = fromList
      . concatMap (\(nID, Prior p) -> [ ((nID, maybe "Undecided" id lbl), show count) | (lbl, count) <- M.toList p])
      . M.toList
      . M.mapKeysWith mappend snd
      $ mapping


studentsPage :: Env -> IO Resource
studentsPage env
   = HTMLFile
   . panel
   . htmlTable (htmlStudentID env) (const $ htmlLabel "Number of entries") text
   . fromList
   . map (\(x,y) -> ((x,()),y))
   <$> countStudentEntries (connection env)



studentModelsPage :: FileType -> Env -> IO Resource
studentModelsPage ft env = do
   tbl <- toTableFromRows (! "studentid") (evStates . (! "studentmodel")) <$> finalRecords (connection env)
   return $ case ft of
      CSV  -> CSVFile $
         csvTable show show (percentage 3) tbl
      HTML -> HTMLFile $
         ( panel $
            styleA "overflow:scroll"
            <> htmlTable (htmlStudentID env) htmlLabel htmlPercentage tbl
         )
         <> htmlDownloadCSV env



tasksPage :: Env -> IO Resource
tasksPage env
   = HTMLFile
   . panel
   . htmlTable (htmlStudentID env) (htmlTaskID env) htmlStrategy
   . toTable (! "studentid") (! "taskid") (! "evidence")
   <$> allRecords (connection env)



optionsPage :: Env -> IO Resource
optionsPage env = do
   files <- findDatabases
   times <- mapM getModificationTime files
   return $ HTMLFile $ panel $
      h1 "Database" <>
      table False (zipWith f files times)
 where
   f file time =
      [ (if file == database env then bold else link (urlFor env {database = file})) (string file)
      , text time ]


-------------------------------------------------------------------------------
-- * Network stuff

trans :: Evidence -> Network () -> Network Probability
trans ev = mapNodes $ \n ->
   let ps = case lookup (nodeId n) (fromEvidenceTp ev) of
               Just (Index i)    -> take (size n) [ if a==i then 1 else 0 | a <- [0..] ]
               Just (Virtual xs) -> map snd xs
               Nothing           -> replicate (size n) 0

   in n { states = zipWith (\(s, _) a -> (s, a)) (states n) ps }