<commit_before>{-# LANGUAGE LambdaCase, OverloadedStrings #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

import ViperVM.Platform.Host as V
import ViperVM.Platform.PlatformInfo
import ViperVM.Platform.Loading
import ViperVM.Platform.Config
import ViperVM.Platform.Topology as V
import ViperVM.Arch.OpenCL.All as CL

import Control.Concurrent.STM
import qualified Data.Set as Set
import Data.Set (Set)
-- FIXME: remove unsafe parts
import System.IO.Unsafe (unsafePerformIO)

import Control.Applicative ((<$>))
import Control.Monad (msum, guard, forM_, when)
import Control.Monad.Trans.Class (lift)
import Data.Char (toLower)
import Data.Function (on)
import Data.List (intersperse, groupBy)
import Data.Maybe (isJust, fromJust, fromMaybe, listToMaybe)
import Data.Text.Lazy (pack)
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Foldable as Fold
import System.Environment
import Text.Printf
import Control.Exception (try)
import Network.HTTP.Base (urlEncode)
import Network.Socket (withSocketsDo)

import Diagrams.Prelude (text, (<>), rect)
import qualified Diagrams.Prelude as Diag
import Diagrams.Core (renderDia)
import Diagrams.Backend.SVG

import Data.Graph.Inductive
import qualified Data.GraphViz as GV
import qualified Data.GraphViz.Exception as GV
import qualified Data.GraphViz.Attributes.Complete as GV

import Happstack.Server

import Text.Blaze.Html5 ((!), toHtml, docTypeHtml, toValue, Html, preEscapedToMarkup, preEscapedToValue)
import qualified Text.Blaze.Renderer.Text as BlazeT
import qualified Text.Blaze.Html5.Attributes as A
import qualified Text.Blaze.Html5 as H
import Text.Blaze.Svg.Renderer.Utf8 (renderSvg)

main :: IO ()
main = withSocketsDo $ do

   -- Loading platform
   pf <- loadPlatform defaultConfig {
      filterOpenCLDevices = fmap (notElem CL.CL_DEVICE_TYPE_CPU) . getDeviceType'
   }

   getArgs >>= \case
      []  -> server (nullConf { port = 8000}) pf
      [p] -> server (nullConf { port = read p}) pf
      _   -> putStrLn =<< (printf "Usage: %s [PORT]" <$> getProgName)


server :: Conf -> V.Host -> IO ()
server conf pf = do
   putStrLn (printf "Starting Web server at localhost:%d" (port conf))
   simpleHTTP conf $ msum [
           -- Show platform information
           dir "platform" $ do
               (mems,procs,nets) <- lift . atomically $ do
                  let extractMem xs x = return (x:xs)
                  mems <- reverse <$> foldMemories pf [] extractMem
                  procs <- Set.toList . Set.unions <$> mapM (readTVar . memoryProcs) mems
                  nets <- Set.toList . Set.unions <$> mapM (readTVar . memoryNetworks) mems
                  return (mems,procs,nets)
               ok . toResponse . appTemplate pf $ showPlatform pf mems procs nets

           -- Show welcome screen
         , nullDir >> (ok . toResponse . appTemplate pf $ showWelcome)
      ]

appTemplate :: V.Host -> Html -> Html
appTemplate pf bdy = docTypeHtml $ do
   H.head $ do
      H.title "ViperVM Web Interface"
      H.meta ! A.httpEquiv "Content-Type"
             ! A.content "text/html;charset=utf-8"
      css
   H.body $ do
      H.div "ViperVM Web Interface"
         ! A.class_ "headtitle"
      bdy

showWelcome :: Html
showWelcome = do
   H.p "Welcome to ViperVM Web Interface"
   H.a "Platform information" ! A.href "/platform"

showPlatform :: V.Host -> [Memory] -> [Proc] -> [V.Network] -> Html
showPlatform pf mems procs nets= do
   let 
      showInfo x = putStrLn $ "  - " ++ x

      memoriesStr x 
         | x <= 1    = printf "%d memory found" x
         | otherwise = printf "%d memories found" x
      procsStr x 
         | x <= 1    = printf "%d processor found" x
         | otherwise = printf "%d processors found" x
      netsStr x 
         | x <= 1    = printf "%d network found" x
         | otherwise = printf "%d networks found" x

   H.h2 "Memories"
   H.ul $ forM_ mems $ \mem -> do
      H.li . toHtml $ (unsafePerformIO $ memoryInfo mem)

   H.h2 "Processors"
   H.ul $ forM_ procs $ \p -> do
      H.li . toHtml $ (unsafePerformIO $ procInfo p)

   H.h2 "Networks"
   H.ul $ forM_ nets $ \p -> do
      H.li . toHtml $ (unsafePerformIO $ networkInfo p)

css :: Html
css = do
   H.style $ "\
      \  body {\n\
      \     font-family:cursive;\n\
      \     background-color: #F0F0F0;\n\
      \     font-color: #B9B9B9;\n\
      \  }\n\
      \  .headtitle {\n\
      \     border: solid 1px rgb(0,0,0);\n\
      \     text-align:center;\n\
      \     font-size:3em;\n\
      \     color: #303030;\n\
      \  }\n\
      \  h1 {\n\
      \     text-align:center;\n\    
      \  }"
<commit_msg>Better style<commit_after>{-# LANGUAGE LambdaCase, OverloadedStrings #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

import ViperVM.Platform.Host as V
import ViperVM.Platform.PlatformInfo
import ViperVM.Platform.Loading
import ViperVM.Platform.Config
import ViperVM.Platform.Topology as V
import ViperVM.Arch.OpenCL.All as CL

import Control.Concurrent.STM
import qualified Data.Set as Set
import Data.Set (Set)
-- FIXME: remove unsafe parts
import System.IO.Unsafe (unsafePerformIO)

import Control.Applicative ((<$>))
import Control.Monad (msum, guard, forM_, when)
import Control.Monad.Trans.Class (lift)
import Data.Char (toLower)
import Data.Function (on)
import Data.List (intersperse, groupBy)
import Data.Maybe (isJust, fromJust, fromMaybe, listToMaybe)
import Data.Text.Lazy (pack)
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Foldable as Fold
import System.Environment
import Text.Printf
import Control.Exception (try)
import Network.HTTP.Base (urlEncode)
import Network.Socket (withSocketsDo)

import Diagrams.Prelude (text, (<>), rect)
import qualified Diagrams.Prelude as Diag
import Diagrams.Core (renderDia)
import Diagrams.Backend.SVG

import Data.Graph.Inductive
import qualified Data.GraphViz as GV
import qualified Data.GraphViz.Exception as GV
import qualified Data.GraphViz.Attributes.Complete as GV

import Happstack.Server

import Text.Blaze.Html5 ((!), toHtml, docTypeHtml, toValue, Html, preEscapedToMarkup, preEscapedToValue)
import qualified Text.Blaze.Renderer.Text as BlazeT
import qualified Text.Blaze.Html5.Attributes as A
import qualified Text.Blaze.Html5 as H
import Text.Blaze.Svg.Renderer.Utf8 (renderSvg)

main :: IO ()
main = withSocketsDo $ do

   -- Loading platform
   pf <- loadPlatform defaultConfig {
      filterOpenCLDevices = fmap (notElem CL.CL_DEVICE_TYPE_CPU) . getDeviceType'
   }

   getArgs >>= \case
      []  -> server (nullConf { port = 8000}) pf
      [p] -> server (nullConf { port = read p}) pf
      _   -> putStrLn =<< (printf "Usage: %s [PORT]" <$> getProgName)


server :: Conf -> V.Host -> IO ()
server conf pf = do
   putStrLn (printf "Starting Web server at localhost:%d" (port conf))
   simpleHTTP conf $ msum [
           -- Show platform information
           dir "platform" $ do
               (mems,procs,nets) <- lift . atomically $ do
                  let extractMem xs x = return (x:xs)
                  mems <- reverse <$> foldMemories pf [] extractMem
                  procs <- Set.toList . Set.unions <$> mapM (readTVar . memoryProcs) mems
                  nets <- Set.toList . Set.unions <$> mapM (readTVar . memoryNetworks) mems
                  return (mems,procs,nets)
               ok . toResponse . appTemplate pf "Platform" $ showPlatform pf mems procs nets

           -- Show welcome screen
         , nullDir >> (ok . toResponse . appTemplate pf "Welcome" $ showWelcome)
      ]

appTemplate :: V.Host -> String -> Html -> Html
appTemplate pf title bdy = docTypeHtml $ do
   H.head $ do
      H.title "ViperVM Web Interface"
      H.meta ! A.httpEquiv "Content-Type"
             ! A.content "text/html;charset=utf-8"
      css
   H.body $ do
      H.div (toHtml $ "ViperVM / " ++ title)
         ! A.class_ "headtitle"
      bdy

showWelcome :: Html
showWelcome = do
   H.p "Welcome to ViperVM Web Interface"
   H.a "Platform information" ! A.href "/platform"

showPlatform :: V.Host -> [Memory] -> [Proc] -> [V.Network] -> Html
showPlatform pf mems procs nets= do
   let 
      showInfo x = putStrLn $ "  - " ++ x

      memoriesStr x 
         | x <= 1    = printf "%d memory found" x
         | otherwise = printf "%d memories found" x
      procsStr x 
         | x <= 1    = printf "%d processor found" x
         | otherwise = printf "%d processors found" x
      netsStr x 
         | x <= 1    = printf "%d network found" x
         | otherwise = printf "%d networks found" x

   H.h2 "Memories"
   H.ul $ forM_ mems $ \mem -> do
      H.li . toHtml $ (unsafePerformIO $ memoryInfo mem)

   H.h2 "Processors"
   H.ul $ forM_ procs $ \p -> do
      H.li . toHtml $ (unsafePerformIO $ procInfo p)

   H.h2 "Networks"
   H.ul $ forM_ nets $ \p -> do
      H.li . toHtml $ (unsafePerformIO $ networkInfo p)

css :: Html
css = do
   H.style $ "\
      \  body {\n\
      \     font-family:cursive;\n\
      \     background-color: #F0F0F0;\n\
      \     font-color: #B9B9B9;\n\
      \  }\n\
      \  .headtitle {\n\
      \     border: solid 1px #404040;\n\
      \     border-radius: 5px;\n\
      \     box-shadow: 10px 10px 5px #888888;\n\
      \     text-align:left;\n\
      \     padding-left: 5px;\n\
      \     font-size:2em;\n\
      \     color: #D0D0D0;\n\
      \     background-color: #404040;\n\
      \     font-family:serif;\n\
      \     font-style:italic;\n\
      \  }\n\
      \  h1 {\n\
      \     text-align:center;\n\    
      \  }"

{'fraction_non_alphanumeric': 0.11583776457095193, 'fraction_numerical': 0.009279532895422792, 'mean_word_length': 2.4404591104734576, 'pattern_counts': {'":': 0, '<': 35, '<?xml version=': 0, '>': 52, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1017187', 'n_tokens_mistral': 3323, 'n_tokens_neox': 3165, 'n_words': 894}