Add df1-html (#47)

* Add df1-html

.gitignore

@@ -1,3 +1,4 @@
 dist
 result
 .*.sw[a-p]
+dist-newstyle/

cabal.project

@@ -8,3 +8,4 @@ packages:
   di-df1/
   di-handle/
   di-monad/
+  df1-html/

df1-html/CHANGELOG.md

@@ -0,0 +1,4 @@
+# Version 0.1
+
+* Initial version
+

df1-html/LICENSE.txt

@@ -0,0 +1,30 @@
+Copyright (c) 2020, Renzo Carbonara
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Renzo Carbonara nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

df1-html/README.md

@@ -0,0 +1,7 @@
+# df1-html
+
+Render and parse logs from [df1] (https://hackage.haskell.org/package/df1) as HTML using the library [xmlbf] (https://hackage.haskell.org/package/xmlbf).
+
+See the [BSD3 LICENSE](https://github.com/k0001/di/blob/master/df1-html/LICENSE.txt)
+file to learn about the legal terms and conditions for this library.
+

df1-html/Setup.hs

@@ -0,0 +1,4 @@
+#! /usr/bin/env nix-shell
+#! nix-shell ./shell.nix -i runghc
+import Distribution.Simple
+main = defaultMain

df1-html/df1-html.cabal

@@ -0,0 +1,56 @@
+name: df1-html
+version: 0.1
+author: Melisa Laura Diaz
+maintainer: renλren.zone
+copyright: Renzo Carbonara 2020
+license: BSD3
+license-file: LICENSE.txt
+extra-source-files: 
+  README.md
+  CHANGELOG.md
+  theme-solarized-dark.css
+  theme-solarized-dark.png
+  theme-solarized-light.css
+  theme-solarized-light.png
+category: Logging
+build-type: Simple
+cabal-version: >=1.18
+synopsis: Render and parse df1 logs as HTML
+description: Render and parse df1 logs as HTML
+homepage: https://github.com/k0001/di
+bug-reports: https://github.com/k0001/di/issues
+
+library
+  hs-source-dirs: lib
+  default-language: Haskell2010
+  exposed-modules: Df1.Html.Render, Df1.Html.Parse
+  build-depends:
+    attoparsec,
+    base >=4.9 && <5.0,
+    bytestring,
+    containers,
+    df1,
+    text,
+    time,
+    xmlbf
+  ghcjs-options: -Wall -O3
+  ghc-options: -Wall -O2
+
+test-suite test
+  default-language: Haskell2010
+  ghc-options: -threaded
+  type: exitcode-stdio-1.0
+  hs-source-dirs: test
+  main-is: Main.hs
+  build-depends:
+    base,
+    containers,
+    df1,
+    df1-html,
+    QuickCheck,
+    tasty,
+    tasty-hunit,
+    tasty-quickcheck,
+    text,
+    time,    
+    xmlbf

df1-html/lib/Df1/Html/Parse.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Df1.Html.Parse (log) where
+
+import Control.Applicative
+import qualified Data.Attoparsec.ByteString as AB
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Encoding as TLE
+import qualified Df1 as D
+import qualified Xmlbf as X
+import Prelude hiding (log)
+
+-- | An "Xmlbf" parser for a 'D.Log' rendered as HTML as 'Df1.Html.Render.log' renders it.
+-- 
+-- Notice that this parser will not ignore leading and trailing white space in the HTML.
+-- It will become part of the parsed 'D.Key', 'D.Value', 'D.Segment', 'D.Message'.
+log :: X.Parser D.Log
+log = X.pElement "div" $ do
+  attrClass "df1-log"
+  t <- parseTime
+  p <- parsePaths
+  l <- parseLevel
+  m <- parseMessage
+  let raw = BL.toStrict $ TLE.encodeUtf8 $ TL.intercalate " " [t, p, l, m]
+  case AB.parseOnly D.parse raw of
+    Left _ -> fail "Could not parse Log."
+    Right a -> pure a
+
+attrClass :: T.Text -> X.Parser ()
+attrClass t = do
+  attrs <- X.pAttr "class"
+  case elem t (T.words attrs) of
+    False -> fail ("Expected \"class\" value to contain " <> show t <> ".")
+    True -> pure ()
+
+parseTime :: X.Parser TL.Text
+parseTime = X.pElement "span" $ do 
+  attrClass "df1-time"
+  X.pText
+
+parseLevel :: X.Parser TL.Text
+parseLevel = X.pElement "span" $ do 
+  attrClass "df1-level"
+  X.pText
+
+parsePaths :: X.Parser TL.Text
+parsePaths = X.pElement "span" $ do 
+  attrClass "df1-path"
+  TL.intercalate " " <$> many (parsePush <|> parseAttr)
+
+parsePush :: X.Parser TL.Text
+parsePush = X.pElement "span" $ do
+  attrClass "df1-push"
+  t <- X.pText
+  s <- parseSeg
+  pure (t <> s)
+
+parseSeg :: X.Parser TL.Text
+parseSeg = X.pElement "span" $ do 
+  attrClass "df1-seg"
+  X.pText <|> pure ""
+
+parseAttr :: X.Parser TL.Text
+parseAttr = X.pElement "span" $ do
+  attrClass "df1-attr"
+  k <- parseKey
+  eq <- X.pText
+  v <- parseValue
+  pure (k <> eq <> v)
+
+parseKey :: X.Parser TL.Text
+parseKey = X.pElement "span" $ do 
+  attrClass "df1-key"
+  X.pText <|> pure ""
+
+parseValue :: X.Parser TL.Text
+parseValue = X.pElement "span" $ do 
+  attrClass "df1-value"
+  X.pText <|> pure ""
+
+parseMessage :: X.Parser TL.Text
+parseMessage = X.pElement "span" $ do 
+  attrClass "df1-msg"
+  X.pText <|> pure ""

df1-html/lib/Df1/Html/Render.hs

@@ -0,0 +1,137 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Df1.Html.Render
+  ( log,
+   -- * Themes
+   --
+   -- $themes
+  )
+where
+
+import qualified Data.ByteString.Builder as BB
+import qualified Data.ByteString.Lazy as BL
+import Data.Foldable (toList)
+import Data.List (intercalate)
+import qualified Data.Sequence as Seq
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.Lazy as TL
+import qualified Data.Time.Clock.System as Time
+import qualified Df1 as D
+import qualified Df1.Render as DR
+import qualified Xmlbf as X
+import Prelude hiding (log)
+
+-- | Converts 'D.Log' into a list of 'X.Node's from "Xmlbf" to render it as HTML.
+--
+-- Example log: 
+-- @1999-12-20T07:11:39.230553031Z \/foo x=a y=b \/bar \/qux z=c z=d WARNING Something@
+--
+-- The generated HTML matches the following CSS selectors: 
+--
+-- [@.df1-log.df1-debug@]: 
+--
+-- [@.df1-log.df1-info@]: 
+--
+-- [@.df1-log.df1-notice@]: 
+--
+-- [@.df1-log.df1-warning@]: 
+--
+-- [@.df1-log.df1-error@]: 
+--
+-- [@.df1-log.df1-critical@]:
+--
+-- [@.df1-log.df1-alert@]:
+--
+-- [@.df1-log.df1-emergency@]: Top level container for a 'D.Log' entry of a particular 'D.Level'.
+--
+-- [@.df1-log .df1-time@]: Timestamp - Example: @1999-12-20T07:11:39.230553031Z@
+--
+-- [@.df1-log .df1-path@]: Full list of 'D.Path's - Example: @\/foo x=a y=b \/bar \/qux z=c z=d@
+-- 
+-- [@.df1-log .df1-path .df1-push@]: Single 'D.Push' - Examples: @\/foo@, @\/bar@, @\/qux@
+--
+-- [@.df1-log .df1-path .df1-push .df1-seg@]: Single 'D.Segment' - Example: @foo@
+-- 
+-- [@.df1-log .df1-path .df1-attr@]: Single 'D.Attr' - Example: @x=a@, @y=b@, @z=c@, @z=d@
+--
+-- [@.df1-log .df1-path .df1-attr .df1-key@]: Single 'D.Key' - Example: @x@, @y@, @z@, @z@
+--
+-- [@.df1-log .df1-path .df1-attr .df1-value@]: Single 'D.Value' - Example: @a@, @b@, @c@, @d@
+-- 
+-- [@.df1-log .df1-level@]: 'D.Level' - Example: @WARNING@
+--
+-- [@.df1-log .df1-msg@]: 'D.Message' - Example: @Something@
+--
+log :: D.Log -> [X.Node]
+log x =
+  X.element "div" [("class", "df1-log " <> levelClass (D.log_level x))] $
+    mconcat
+      [ timeHtml (D.log_time x),
+        X.text " ",
+        pathsHtml (D.log_path x),
+        X.text " ",
+        levelHtml (D.log_level x),
+        X.text " ",
+        messageHtml (D.log_message x)
+      ]
+
+levelClass :: D.Level -> T.Text
+levelClass l = "df1-" <> TL.toStrict (TL.toLower (levelToText l))
+
+timeHtml :: Time.SystemTime -> [X.Node]
+timeHtml t = spanClass "df1-time" (X.text (textLazyFromBuilder (DR.iso8601 t)))
+
+textLazyFromBuilder :: BB.Builder -> TL.Text
+textLazyFromBuilder b = TL.fromStrict (TE.decodeUtf8 (BL.toStrict (BB.toLazyByteString b)))
+
+levelHtml :: D.Level -> [X.Node]
+levelHtml l = spanClass "df1-level" (X.text (levelToText l))
+
+levelToText :: D.Level -> TL.Text
+levelToText l =
+  case l of
+    D.Debug -> "DEBUG"
+    D.Info -> "INFO"
+    D.Notice -> "NOTICE"
+    D.Warning -> "WARNING"
+    D.Error -> "ERROR"
+    D.Critical -> "CRITICAL"
+    D.Alert -> "ALERT"
+    D.Emergency -> "EMERGENCY"
+
+messageHtml :: D.Message -> [X.Node]
+messageHtml m = spanClass "df1-msg" (X.text (textLazyFromBuilder (DR.message m)))
+
+pathsHtml :: Seq.Seq D.Path -> [X.Node]
+pathsHtml ps = spanClass "df1-path" (intercalate (X.text " ") (fmap pathHtml (toList ps)))
+
+pathHtml :: D.Path -> [X.Node]
+pathHtml p = case p of
+  D.Push seg -> spanClass "df1-push" (X.text "/" <> segmentHtml seg)
+  D.Attr key val -> spanClass "df1-attr" (keyHtml key <> X.text "=" <> valueHtml val)
+
+segmentHtml :: D.Segment -> [X.Node]
+segmentHtml s = spanClass "df1-seg" (X.text (textLazyFromBuilder (DR.segment s)))
+
+keyHtml :: D.Key -> [X.Node]
+keyHtml k = spanClass "df1-key" (X.text (textLazyFromBuilder (DR.key k)))
+
+valueHtml :: D.Value -> [X.Node]
+valueHtml v = spanClass "df1-value" (X.text (textLazyFromBuilder (DR.value v)))
+
+spanClass :: T.Text -> [X.Node] -> [X.Node]
+spanClass t = X.element "span" [("class", t)]
+
+-- $themes
+-- 
+-- If you need to style the rendered HTML, you can use some of the themes shipped with this library.
+-- 
+-- == [theme-solarized-dark.css](https://github.com/k0001/di/blob/html/df1-html/theme-solarized-dark.css?raw=true)
+--
+-- ![theme-solarized-dark](https://github.com/k0001/di/blob/html/df1-html/theme-solarized-dark.png?raw=true)
+--
+-- == [theme-solarized-light.css](https://github.com/k0001/di/blob/html/df1-html/theme-solarized-light.css?raw=true)
+--
+-- ![theme-solarized-light](https://github.com/k0001/di/blob/html/df1-html/theme-solarized-light.png?raw=true)