haskus-web (empty) → 1.0

raw patch · 7 files changed

+238/−0 lines, 7 filesdep +basedep +bytestringdep +clay

Dependencies added: base, bytestring, clay, happstack-server, happstack-server-tls, haskus-utils-compat, lucid, text

Files

LICENSE +27/−0
haskus-web.cabal +44/−0
src/lib/Haskus/Web/Css.hs +6/−0
src/lib/Haskus/Web/Html.hs +40/−0
src/lib/Haskus/Web/JQuery.hs +65/−0
src/lib/Haskus/Web/Response.hs +50/−0
src/lib/Haskus/Web/Server.hs +6/−0

+ LICENSE view

@@ -0,0 +1,27 @@+Copyright (c) 2013-2017, Haskus organization+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 Sylvain Henry 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 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.

+ haskus-web.cabal view

@@ -0,0 +1,44 @@+name:                haskus-web+version:             1.0+synopsis:            Haskus web+license:             BSD3+license-file:        LICENSE+author:              Sylvain Henry+maintainer:          sylvain@haskus.fr+homepage:            http://www.haskus.org+copyright:           Sylvain Henry 2019+category:            System+build-type:          Simple+cabal-version:       1.20++description:+   Haskus web related modules++source-repository head+  type: git+  location: git://github.com/haskus/haskus-web.git++library+  exposed-modules:+    Haskus.Web.Server+    Haskus.Web.Css+    Haskus.Web.Html+    Haskus.Web.Response+    Haskus.Web.JQuery++  other-modules:++  build-depends:       +      base                      >= 4.9 && < 5+   ,  haskus-utils-compat+   ,  bytestring+   ,  text+   ,  clay+   ,  lucid+   ,  happstack-server+   ,  happstack-server-tls++  build-tools: +  ghc-options:          -Wall+  default-language:     Haskell2010+  hs-source-dirs:       src/lib

+ src/lib/Haskus/Web/Css.hs view

@@ -0,0 +1,6 @@+module Haskus.Web.Css+   ( module Clay+   )+where++import Clay

+ src/lib/Haskus/Web/Html.hs view

@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}++module Haskus.Web.Html+   ( module Lucid+   , module Lucid.Base+   , renderText'+   , minLength_+   , emptyAttribute+   , nbsp_+   , lightTripleDashVert+   , property_+   , prefix_+   )+where++import Lucid+import Lucid.Base+import Data.Text+import Data.Text.Lazy (toStrict)++renderText' :: Html a -> Text+renderText' = toStrict . renderText++minLength_ :: Text -> Attribute+minLength_ = makeAttribute "minlength"++property_ :: Text -> Attribute+property_ = makeAttribute "property"++prefix_ :: Text -> Attribute+prefix_ = makeAttribute "prefix"++emptyAttribute :: Attribute+emptyAttribute = makeAttribute mempty mempty++nbsp_ :: Html ()+nbsp_ = toHtmlRaw ("&nbsp;" :: Text)++lightTripleDashVert :: Html ()+lightTripleDashVert = toHtmlRaw ("&#9478;" :: Text)

+ src/lib/Haskus/Web/JQuery.hs view

@@ -0,0 +1,65 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++module Haskus.Web.JQuery+   ( jqueryHtmlHeader+   , jqueryFiles+   )+where++import Haskus.Web.Response+import Haskus.Web.Server+import Haskus.Web.Html+import Haskus.Utils.Embed.ByteString++import Data.Text+import Control.Monad++-- | Add jquery headers+jqueryHtmlHeader :: Bool -> Html ()+jqueryHtmlHeader minimized = do+   let+      addScript :: Text -> Text -> Html ()+      addScript mini normal =+         script_ [ src_ (if minimized then mini else normal) ] (mempty :: Html ())++   addScript+      "/script/jquery/jquery-3.2.1.min.js"+      "/script/jquery/jquery-3.2.1.min.js"   -- TODO: add normal jquery++   -- JQuery UI: some widgets+   addScript+      "/script/jquery/jquery-ui.min.js"+      "/script/jquery/jquery-ui.js"++   -- allow jquery UI to support Touch Screens+   addScript+      "/script/jquery/jquery.ui.touch-punch.min.js"+      "/script/jquery/jquery.ui.touch-punch.min.js" --TODO: add normal script++   -- ability to block the whole screen with a JS popup+   addScript+      "/script/jquery/jquery.blockUI.js" --TODO: minimized script+      "/script/jquery/jquery.blockUI.js"++   link_ [ rel_  "stylesheet"+         , type_ "text/css"+         , href_ "/style/jquery/jquery-ui.theme.css"+         ]++-- | Serve JQuery files+jqueryFiles :: ServerPartT IO Response+jqueryFiles = msum+   [ dir "script" $ dir "jquery" $ msum+      [ dir "jquery-3.2.1.min.js"          $ sendJS $ $(embedBSFile "src/scripts/jquery-3.2.1.min.js")+      , dir "jquery-ui.min.js"             $ sendJS $ $(embedBSFile "src/scripts/jquery-ui.min.js")+      , dir "jquery-ui.min.js"             $ sendJS $ $(embedBSFile "src/scripts/jquery-ui.min.js")+      , dir "jquery-ui.js"                 $ sendJS $ $(embedBSFile "src/scripts/jquery-ui.js")+      , dir "jquery.ui.touch-punch.min.js" $ sendJS $ $(embedBSFile "src/scripts/jquery.ui.touch-punch.min.js")+      , dir "jquery.blockUI.js"            $ sendJS $ $(embedBSFile "src/scripts/jquery.blockUI.js")+      ]+   , dir "style" $ dir "jquery" $ msum+      [ dir "jquery-ui.theme.css"            $ sendJS $ $(embedBSFile "src/css/jquery-ui.theme.css")+      ]+   ]

+ src/lib/Haskus/Web/Response.hs view

@@ -0,0 +1,50 @@+module Haskus.Web.Response+   ( sendJson+   , sendJS+   , sendPNG+   , sendJPG+   , sendData+   , sendBinary+   , sendLazyJson+   , sendLazyData+   )+where++import qualified Data.ByteString       as BS+import qualified Data.ByteString.Lazy  as LBS+import qualified Data.ByteString.Char8 as BS8++import Haskus.Web.Server++-- | Send JSON text+sendJson :: BS.ByteString -> ServerPartT IO Response+sendJson = sendData "application/json"++-- | Send JS script+sendJS :: BS.ByteString -> ServerPartT IO Response+sendJS = sendData "text/javascript"++-- | Send binary data+sendBinary :: BS.ByteString -> ServerPartT IO Response+sendBinary = sendData "application/octet-stream"++-- | Send a PNG image+sendPNG :: BS.ByteString -> ServerPartT IO Response+sendPNG = sendData "image/png"++-- | Send a JPG image+sendJPG :: BS.ByteString -> ServerPartT IO Response+sendJPG = sendData "image/jpg"++-- | Send data with the given MIME content type+sendData :: String -> BS.ByteString -> ServerPartT IO Response+sendData mime dat = ok (toResponseBS (BS8.pack mime) (LBS.fromStrict dat))++-- | Send JSON text+sendLazyJson :: LBS.ByteString -> ServerPartT IO Response+sendLazyJson = sendLazyData "application/json"++-- | Send data with the given MIME content type+sendLazyData :: String -> LBS.ByteString -> ServerPartT IO Response+sendLazyData mime dat = ok (toResponseBS (BS8.pack mime) dat)+

+ src/lib/Haskus/Web/Server.hs view

@@ -0,0 +1,6 @@+module Haskus.Web.Server+   ( module Happstack.Server+   )+where++import Happstack.Server