+ +

Current Draft

Saved Drafts

+ + + + + Not connected to server +

+ +

+ Allow Deletion + + + + + + + + + +

Id	Title	Actions

+ +

+ Blub. +

+ +

+ + diff --git a/webgui/data/style.css b/webgui/data/style.css new file mode 100644 index 0000000..53ddb7a --- /dev/null +++ b/webgui/data/style.css @@ -0,0 +1,159 @@ +.table { display: table; } +.tr { display: table-row; } +.tc { display: table-cell; } + +.table .table, table .table, .table table, table table { width:100%; height:100%; } + +.fatal { + z-index:-1; + position:fixed; + top:50%; + left:50%; + transform: translate(-50%, -50%); + background-color:#fdd; + border:2px solid #c00; + text-align:center; + vertical-align:center; + padding:1em; + font-weight:600; +} + +h1 { + font-size:1.5em; + font-weight:normal; + text-align:center; +} + +thead td { + font-size:1em; + font-weight:600; + text-align:center; +} + +thead tr:last-child { + padding-bottom:0.125em; + border-bottom:1px solid #ddd; + margin-bottom:0.125em; +} + +.editorButtonContainer { + text-align:center; +} + +.editorButton { + display:inline-block; + width:8em; +} + +#editorTitle { + width:100%; + box-sizing:border-box; + margin:0 0 0.25em 0; +} + +#editorText { + width:100%; + box-sizing:border-box; + margin:0 0 0.25em 0; + resize:vertical; + min-height:25em; +} + +#editorStatus { + display:block; + margin:0 0 0.25em 0; + font-size:0.75em; +} + +#editorStatus:after { + display:block; + clear:both; + content:''; +} + +#bbcodeStatus { + display:block; + margin:0 0 0.25em 0; + font-size:0.75em; + float:right; + color:#c00000; +} + +/*----- Tabs -----*/ +.tabs { + display:block; + width:98%; + min-height:98%; + position:absolute; + left:1%; + top:1%; +} + +/*----- Tab Links -----*/ +.tab-links { + display:block; + height:2.2em; + margin:0; + padding:0 0.5em; + z-index:0; +} + +/* Clearfix */ +.tab-links:after { + display:block; + clear:both; + content:''; +} + +.tab-links li { + margin:0px 0.5em; + float:left; + list-style:none; +} + +.tab-links a { + padding:0.5em 1em; + display:inline-block; + border-radius:3px 3px 0px 0px; + background:#fff; + font-size:1em; + font-weight:600; + color:#4c4c4c; + transition:all linear 0.15s; +} + +.tab-links a:hover { + text-decoration:none; +} + +li.active a, li.active a:hover { + background:#f0f0f0; + color:#4c4c4c; + text-decoration:none; + } + +#errors-tab a { + color:#c00000; +} + +/*----- Content of Tabs -----*/ +.tab-content { + padding:0.5em; + border:1px solid #ddd; + border-radius:3px; + box-shadow:-1px 1px 1px rgba(0,0,0,0.15); + background:#fff; + box-sizing:border-box; + width:100%; + z-index:1; + margin-top:-1px; + margin-bottom:1%; +} + +.tab { + display:none; +} + +.tab.active { + display:block; +} \ No newline at end of file diff --git a/webgui/data/tabs.js b/webgui/data/tabs.js new file mode 100644 index 0000000..1d178d9 --- /dev/null +++ b/webgui/data/tabs.js @@ -0,0 +1,13 @@ +jQuery(document).ready(function() { + jQuery('.tabs .tab-links a').on('click', function(e) { + var currentAttrValue = jQuery(this).attr('href'); + + // Show/Hide Tabs + jQuery('.tabs ' + currentAttrValue).show().siblings().hide(); + + // Change/remove current tab to active + jQuery(this).parent('li').addClass('active').siblings().removeClass('active'); + + e.preventDefault(); + }); +}); diff --git a/webgui/src/Main.hs b/webgui/src/Main.hs index 92aba0e..44bcb88 100644 --- a/webgui/src/Main.hs +++ b/webgui/src/Main.hs @@ -4,10 +4,13 @@ module Main (main) where import qualified Graphics.UI.Threepenny as UI -import qualified Graphics.UI.Threepenny.Core as TP (Config) -import Graphics.UI.Threepenny.Core hiding (Config) +import Graphics.UI.Threepenny.Timer +import qualified Graphics.UI.Threepenny.Core as TP (Config, text) +import Graphics.UI.Threepenny.Core hiding (Config, text) import Thermoprint.Client +import Thermoprint.Printout.BBCode + import Network.WebSockets import Network.Socket (withSocketsDo) import Network.URI @@ -22,6 +25,15 @@ import qualified Data.ByteString.Char8 as CBS import Data.Text (Text) import qualified Data.Text as T +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq + +import Data.Default.Class + +import Data.Time + import Control.Concurrent import Control.Exception import Control.Monad.Catch @@ -30,7 +42,13 @@ import Control.Applicative import Control.Monad import Data.Maybe import Data.Monoid -import Text.Read +import Text.Read hiding (get) +import Data.Either +import Data.List (isPrefixOf) + +import Paths_thermoprint_webgui + +import Debug.Trace data Config = Config { tpConfig :: TP.Config @@ -49,7 +67,13 @@ config :: IO (Opt.Parser Config) config = do p <- fromMaybe 8023 . (readMaybe =<<) <$> lookupEnv portEnv a <- fromMaybe "localhost" <$> lookupEnv hostEnv - return $ Config <$> ((\port addr -> defaultConfig { jsPort = port, jsAddr = addr }) <$> optional (Opt.option Opt.auto $ port p) <*> optional (fmap CBS.pack $ Opt.strOption $ addr a)) + static <- getDataDir + let + config = defaultConfig + { jsCustomHTML = Just "index.html" + , jsStatic = Just static + } + return $ Config <$> ((\port addr -> config { jsPort = port, jsAddr = addr }) <$> optional (Opt.option Opt.auto $ port p) <*> optional (fmap CBS.pack $ Opt.strOption $ addr a)) <*> (BaseUrl Http <$> Opt.strOption (Opt.long "target-addr" <> Opt.short 'A' <> Opt.metavar "HOST" <> Opt.help "Host to connect to" <> Opt.value "localhost" <> Opt.showDefault) <*> Opt.option Opt.auto (Opt.long "target-port" <> Opt.short 'P' <> Opt.metavar "PORT" <> Opt.help "Port to connect to" <> Opt.value 3000 <> Opt.showDefault) @@ -74,37 +98,182 @@ setup :: Config -> Window -> Event (Either WebSocketException URI) -> UI () setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do onEvent socketErr handleSocketErr - return window # set UI.title "Thermoprint" - - title <- UI.input - # set UI.id_ "title" - content <- UI.textarea - # set UI.id_ "content" - draftTable <- UI.table - - saveBtn <- UI.button #+ [string "Save"] - discBtn <- UI.button #+ [string "Discard"] - prntBtn <- UI.button #+ [string "Print"] - - getBody window #+ [ row [ column [ UI.h1 #+ [string "Current draft"] - , row [UI.label # set text "Title" # set UI.for "title", element title] - , element content - , row [ element saveBtn - , element prntBtn - , element discBtn - ] - ] - , column [ UI.h1 #+ [string "Saved drafts"] - , element draftTable - ] - ] - ] + getElementById window "javascriptError" >>= maybeM delete + + changeEditorStatus <- handleEditor + + handleDraftTable changeEditorStatus where - handleSocketErr InvalidMessage = debug "Received unparseable message from websocket" - handleSocketErr e@(Unhandled e') = void $ fatalError (show e') >> liftIO (throwIO e) - fatalError str = (getBody window #) . set children =<< sequence [UI.p # set text str # set UI.id_ "fatal-error"] + handleSocketErr InvalidMessage = emitError "Received unparseable message from server-side websocket" + handleSocketErr ProcessDied = fatal "Thread handling server-side websocket died" + handleSocketErr (Unhandled e') = fatal $ "Unhandled error from server-side websocket: " ++ show e' + emitError str = void $ do + debug str + let + errors = maybe (fatal "No container for nonfatal errors found") return =<< getElementById window "errors" + errorsTab = maybe (fatal "Could not make nonfatal errors visible") return =<< getElementById window "errors-tab" + errors #+ [UI.li # set TP.text str] + errorsTab # set style [("display", "inline-block")] + fatal :: String -> UI a + fatal str = do + (getBody window #) . set children =<< sequence [UI.p # set TP.text str # set UI.class_ "fatal"] + liftIO (throwIO $ ErrorCall str) + return undefined + + maybeM = maybe $ return () + + fatal' :: String -> Maybe a -> UI a + fatal' str = maybe (fatal str) return + + stepper' :: a -> UI (Behavior a, a -> IO ()) + stepper' init = do + (statusEvent, triggerStatusChange) <- liftIO newEvent + status <- stepper init statusEvent + return (status, triggerStatusChange) + + Client{..} = mkClient (Nat $ either (fatal . ("Error while communicating to Thermoprint.Server: " ++) . show) return <=< liftIO . runEitherT) server + + handleEditor = do + title <- fatal' "Could not find editor title field" =<< getElementById window "editorTitle" + text <- fatal' "Could not find editor text field" =<< getElementById window "editorText" + status <- fatal' "Could not find editor status field" =<< getElementById window "editorStatus" + bbcodeStatus <- fatal' "Could not find editor bbcode status field" =<< getElementById window "bbcodeStatus" + + saveButton <- fatal' "Could not find editor save button" =<< getElementById window "saveButton" + printButton <- fatal' "Could not find editor print button" =<< getElementById window "printButton" + discardButton <- fatal' "Could not find editor discard button" =<< getElementById window "discardButton" + + (editorStatus, fmap liftIO -> changeEditorStatus) <- stepper' def + + let + modifyStatus f = changeEditorStatus . f =<< currentValue editorStatus + + on UI.valueChange title $ \str -> modifyStatus (\x -> x { eTitle = if null str then Nothing else Just str }) + on UI.valueChange text $ \str -> modifyStatus (\x -> x { eText = str }) + on UI.valueChange text $ \str -> modifyStatus (\x -> x { ePrintout = bbcode $ T.pack str }) + return title # sink UI.value (fromMaybe "" . eTitle <$> editorStatus) + return text # sink UI.text (eText <$> editorStatus) + return status # sink TP.text (toStatusString <$> editorStatus) + return bbcodeStatus # sink TP.text (toStatusString' . ePrintout <$> editorStatus) + + autoSaveTimer <- timer # set interval 5000 + start autoSaveTimer + + let + saveAction automatic = do + s@(EditorState{..}) <- currentValue editorStatus + when (not $ maybe True null eTitle && null eText) $ case ePrintout of + Left err -> when (not automatic) . emitError $ "Could not save draft due to error parsing bbcode: " ++ show err + Right p -> do + draftId <- case associatedDraft of + Nothing -> draftCreate (T.pack <$> eTitle) p + Just i -> i <$ when (different s) (draftReplace i (T.pack <$> eTitle) p) + time <- liftIO getCurrentTime + modifyStatus (\x -> x { associatedDraft = Just draftId, lastSaved = Just (time, s) }) + where + different s + | Just (_, s') <- lastSaved s = not $ and [ eTitle s == eTitle s' + , eText s == eText s' + ] + | otherwise = True + discardAction = do + maybe (return ()) draftDelete . associatedDraft =<< currentValue editorStatus + modifyStatus $ const def + printAction = do + emitError "Printing not implemented" + + onEvent (tick autoSaveTimer) (const $ saveAction True) + + return saveButton # sink UI.enabled (saveable <$> editorStatus) + return printButton # sink UI.enabled (printable <$> editorStatus) + return discardButton # sink UI.enabled (discardable <$> editorStatus) + + on UI.click saveButton . const $ saveAction False + on UI.click printButton $ const printAction + on UI.click discardButton $ const discardAction + + return changeEditorStatus + + saveable s@EditorState{..} = isRight ePrintout && discardable s + printable EditorState{..} = isRight ePrintout && not (null eText) + discardable EditorState{..} = not (maybe True null eTitle && null eText) + + handleDraftTable changeEditorState = do + allowDeletion <- fatal' "Could not find deletion switch" =<< getElementById window "allowDeletion" + deletion' <- allowDeletion # get UI.checked + + deletion <- stepper deletion' $ UI.checkedChange allowDeletion + let + toTable :: Map DraftId (Maybe DraftTitle) -> UI [Element] + toTable = mapM toLine . Map.toList + + toLine (id@(show -> tId), fromMaybe "" . fmap T.unpack -> title) = do + id' <- UI.td # set TP.text tId + title' <- UI.td # set TP.text title + delete <- UI.button + # set TP.text "Delete" + # sink UI.enabled deletion + on UI.click delete . const $ draftDelete id + load <- UI.button + # set TP.text "Load" + on UI.click load . const $ loadDraft id + actions <- UI.td # set children [load, delete] + UI.tr # set children [id', title', actions] + loadDraft id = do + (title, po) <- draft id + time <- liftIO $ getCurrentTime + let newState = def + { eTitle = fmap T.unpack title + , eText = "unimplemented" -- TODO: implement -- drops data as it is + , ePrintout = Right po + , associatedDraft = Just id + , lastSaved = Just (time, newState) + } + changeEditorState newState + table <- fatal' "Could not find draft table" =<< getElementById window "draftListBody" + initialContent <- toTable =<< drafts + return table # set children initialContent + + onEvent (filterE concernsDrafts dataUpdate) . const $ drafts >>= toTable >>= (\c -> return table # set children c) + where + concernsDrafts :: URI -> Bool + concernsDrafts (uriPath -> p) + | p == "drafts" = True + | "draft/" `isPrefixOf` p = True + | otherwise = False + + +data EditorState = EditorState + { eTitle :: Maybe String + , eText :: String + , ePrintout :: Either BBCodeError Printout + , lastSaved :: Maybe (UTCTime, EditorState) + , associatedDraft :: Maybe DraftId + } + deriving (Show) + +instance Default EditorState where + def = EditorState + { eTitle = Nothing + , eText = "" + , ePrintout = Right mempty + , lastSaved = Nothing + , associatedDraft = Nothing + } + +toStatusString :: EditorState -> String +toStatusString EditorState{..} + | null eTitle + , null eText = "Draft is empty" + | Just (t, _) <- lastSaved = "Last saved: " ++ formatTime defaultTimeLocale "%F %X" t + | otherwise = "Draft was never saved" + +toStatusString' :: Either BBCodeError a -> String +toStatusString' (Right _) = "" +toStatusString' (Left e) = show e + data WebSocketException = ProcessDied | InvalidMessage | Unhandled SomeException deriving (Show) @@ -114,7 +283,7 @@ withWebSocket :: (Config -> Window -> Event (Either WebSocketException URI) -> U withWebSocket setup c@(Config{..}) w = do (dataUpdate, triggerData) <- liftIO newEvent let - rcvEvents = runClient (baseUrlHost server) (baseUrlPort server) "/" $ forever . (triggerData . maybe (Left InvalidMessage) Right . parseURI . T.unpack <=< receiveData) - liftIOLater . void $ forkFinally (rcvEvents `catchAll` (triggerData . Left . Unhandled)) (triggerData $ Left ProcessDied) + rcvEvents = runClient (baseUrlHost server) (baseUrlPort server) "/" $ forever . (triggerData . maybe (Left InvalidMessage) Right . parseURIReference . T.unpack <=< receiveData) + liftIOLater . void $ forkFinally rcvEvents (triggerData . Left . either Unhandled (const ProcessDied)) void $ setup c w dataUpdate diff --git a/webgui/thermoprint-webgui.cabal b/webgui/thermoprint-webgui.cabal index c1f4d19..b76175d 100644 --- a/webgui/thermoprint-webgui.cabal +++ b/webgui/thermoprint-webgui.cabal @@ -16,6 +16,11 @@ build-type: Simple -- extra-source-files: cabal-version: >=1.10 +data-dir: data +data-files: index.html + , style.css + , tabs.js + executable thermoprint-webgui main-is: Main.hs -- other-modules: @@ -31,5 +36,9 @@ executable thermoprint-webgui , network-uri >=2.6.0 && <3 , text >=1.2.2 && <2 , exceptions >=0.8.2 && <1 + , containers >=0.5.6 && <1 + , either >=4.4.1 && <5 + , time >=1.5.0 && <2 + , data-default-class >=0.0 && <1 hs-source-dirs: src default-language: Haskell2010 \ No newline at end of file diff --git a/webgui/thermoprint-webgui.nix b/webgui/thermoprint-webgui.nix index 5eb5912..457f39a 100644 --- a/webgui/thermoprint-webgui.nix +++ b/webgui/thermoprint-webgui.nix @@ -1,6 +1,7 @@ -{ mkDerivation, base, bytestring, exceptions, network, network-uri -, optparse-applicative, stdenv, text, thermoprint-bbcode -, thermoprint-client, threepenny-gui, websockets +{ mkDerivation, base, bytestring, containers, data-default-class +, either, exceptions, network, network-uri, optparse-applicative +, stdenv, text, thermoprint-bbcode, thermoprint-client +, threepenny-gui, time, websockets }: mkDerivation { pname = "thermoprint-webgui"; @@ -9,9 +10,9 @@ mkDerivation { isLibrary = false; isExecutable = true; executableHaskellDepends = [ - base bytestring exceptions network network-uri optparse-applicative - text thermoprint-bbcode thermoprint-client threepenny-gui - websockets + base bytestring containers data-default-class either exceptions + network network-uri optparse-applicative text thermoprint-bbcode + thermoprint-client threepenny-gui time websockets ]; homepage = "http://dirty-haskell.org/tags/thermoprint.html"; description = "Threepenny interface for thermoprint-spec compliant servers"; -- cgit v1.2.3