New version powered by servant

- Side by side input and output
- Form submitted via ajax
- httpie and curl samples

QuickWebApp.hs

@@ -1,88 +1,98 @@
-{-# LANGUAGE FlexibleInstances    #-}
-{-# LANGUAGE OverloadedStrings    #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE TypeOperators         #-}
+
 {-| A quick-and-dirty api generator, for any function `a -> b` which can be wrapped
     inside a function `ByteString -> ByteString`.
     It is inspired from the 'interact' function from 'Prelude'.
 -}
-module QuickWebApp where
-
-import qualified Data.ByteString            as BS
-import qualified Data.ByteString.Lazy       as BL
-import qualified Data.ByteString.Lazy.Char8 as BC
-import qualified Data.Text                  as TS
-import qualified Data.Text.Lazy             as TL
-import qualified Data.Text.Lazy.Encoding    as TL
-import           Network.HTTP.Types.Status
-import           Web.Scotty
-
--- | Represents types which can be converted to a Lazy 'ByteString'
-class ToLBS a where
-    toLBS :: a -> BL.ByteString
-
-instance ToLBS BL.ByteString where
-    toLBS = id
-
-instance ToLBS BS.ByteString where
-    toLBS = BL.fromStrict
-
-instance ToLBS TL.Text where
-    toLBS = TL.encodeUtf8
-
-instance ToLBS TS.Text where
-    toLBS = TL.encodeUtf8 . TL.fromStrict
-
-instance ToLBS String where
-    toLBS = BC.pack
-
--- | Represents types which can be converted from a Lazy 'ByteString'
--- This is intended for other String-like types
-class FromLBS a where
-    fromLBS :: BL.ByteString -> a
-
-instance FromLBS BL.ByteString where
-    fromLBS = id
-
-instance FromLBS BS.ByteString where
-    fromLBS = BL.toStrict
-
-instance FromLBS TL.Text where
-    fromLBS = TL.decodeUtf8
-
-instance FromLBS TS.Text where
-    fromLBS = TL.toStrict . TL.decodeUtf8
-
-instance FromLBS String where
-    fromLBS = BC.unpack
-
--- | Unprocessable entity error code (temporary fix for a missing status in
--- http-types)
-err422 :: Status
-err422 = mkStatus 422 "Unprocessable Entity"
-
--- | Equivalent to 'interactWebOn 3000'
-interactWeb :: (FromLBS a, ToLBS b) => (a -> b) -> IO ()
-interactWeb = interactWebOn 3000
-
--- | Equivalent to 'interactWebEitherOn 3000'
-interactWebEither :: (FromLBS a, ToLBS b, ToLBS e) => (a -> Either e b) -> IO ()
-interactWebEither = interactWebEitherOn 3000
-
--- | Create an API with a 'POST' endpoint
-interactWebOn :: (FromLBS a, ToLBS b) => Int -> (a -> b) -> IO ()
-interactWebOn port f = scotty port $ post "/" $ do
-                c <- body
-                setHeader "Content-Type" "text/plain"
-                raw . toLBS . f . fromLBS $ c
-
--- | Create an API with a 'POST' endpoint
--- If the function fails and returns a 'Left' value, return a 422 response with
--- the error in the body
-interactWebEitherOn :: (FromLBS a, ToLBS b, ToLBS e) => Int -> (a -> Either e b) -> IO ()
-interactWebEitherOn port f = scotty port $ post "/" $ do
-                c <- body
-                setHeader "Content-Type" "text/plain"
-                case f . fromLBS $ c of
-                    Right res -> raw . toLBS $ res
-                    Left err -> status err422 >> (raw . toLBS $ err)
+module QuickWebApp (
+    interactWeb
+  ) where
+
+import           Control.Monad.Trans.Either
+import           Data.Aeson
+import qualified Data.ByteString.Lazy.Char8 as BL8
+import           Data.Either.Combinators
+import qualified Data.Map                   as M
+import           Data.Text                  (Text)
+import           Data.Text.Lazy.Encoding    (decodeUtf8)
+import           GHC.Generics
+import           Network.Wai.Handler.Warp
+import           System.Environment
+
+import Lucid
+import           Servant
+import           Servant.HTML.Lucid
+
+type API = Get '[HTML] Home
+       :<|> ReqBody '[JSON, FormUrlEncoded] Input :> Post '[JSON] Output
+
+
+data Home = Home
+instance ToHtml Home where
+  toHtml Home = doctypehtml_ $ do
+    head_ $ do
+      title_ "Api powered by QuickWebApp"
+      meta_ [charset_ "utf-8"]
+      link_ [rel_ "stylesheet", type_ "text/css",  href_ "http://groundfloor.neocities.org/default.css"]
+    body_ $ do
+      header_ $ do
+        h1_ "interactWeb :: (a -> Either String b) -> IO ()"
+        p_ $ do
+          "Powered by "
+          a_ [href_ "http://hackage.haskell.org/package/servant"] "servant"
+          " and "
+          a_ [href_ "http://hackage.haskell.org/package/lucid"] "lucid"
+      div_ [ style_ "width: 80%; margin: auto;"] $ do
+        div_ [style_ "display: flex; flex-direction: row; align-items: flex-stretch"] $ do
+          section_ [style_ "flex: 1 1 50%;",  class_ "input"] $ do
+            h2_ "Try out your function here"
+            form_ [action_ "/" , method_ "POST"] $ do
+              textarea_ [ name_ "input" ] ""
+              input_ [type_ "submit" , value_ "Test"]
+          section_ [style_ "flex: 1 1 50%", class_ "output"] $ do
+            h2_ "Results here"
+            pre_ $ samp_ [id_ "output"] ""
+        h2_ "You can also curl or httpie"
+        kbd_ "http :8080 input=\"<your input string>\""
+        kbd_ "curl localhost:8080 -d input=\"<your input string>\""
+        h2_ "Where to go from here ?"
+        p_ $ do
+          "TODO: This is where I show you the boilerplate to kickstart \
+          \ your api, but I've not done that yet. "
+          a_ [href_ "http://github.com/jtanguy/quickwebapp/issues/2"] "Corresponding github issue"
+        term "script" [src_ "//code.jquery.com/jquery-1.11.3.min.js"] ""
+      script_ "$(function(){ \
+        \ $('form').submit(function(){ \
+        \    $.post($(this).attr('action'), $(this).serialize(), function(json) { \
+        \         $('#output').html(json.output);\
+        \             }, 'json');\
+        \                 return false;\
+        \                   });\
+        \                   });"
+  toHtmlRaw = toHtml
+
+
+newtype Input = Input { input :: Text } deriving (Show, Eq, Generic)
+
+instance FromJSON Input
+instance FromFormUrlEncoded Input where
+  fromFormUrlEncoded = eitherDecode . encode . M.fromList
+
+newtype Output = Output { output :: Text } deriving (Show, Eq, Generic)
+instance ToJSON Output
+
+interactWeb :: (FromText a, ToText b) => (a -> Either String b) -> IO ()
+interactWeb f = do
+    port <- maybe 8080 read <$> lookupEnv "PORT"
+    run port (serve (Proxy :: Proxy API) (return Home :<|> handler))
+  where
+    handler = maybe (left $ err "Could not convert from text")
+                    (hoistEither . mapBoth err (Output . toText) . f) . fromText . input
+
+err :: String -> ServantErr
+err e = ServantErr 422 "Unprocessable Entity" (BL8.pack (show e)) []
 

default.nix

@@ -1,10 +1,14 @@
-{ mkDerivation, base, bytestring, http-types, scotty, stdenv, text
+{ mkDerivation, aeson, base, bytestring, containers, either, lucid
+, servant, servant-lucid, servant-server, stdenv, text, warp
 }:
 mkDerivation {
   pname = "quickwebapp";
-  version = "2.1.0.0";
+  version = "3.0.0.0";
   src = ./.;
-  buildDepends = [ base bytestring http-types scotty text ];
+  libraryHaskellDepends = [
+    aeson base bytestring containers either lucid servant servant-lucid
+    servant-server text warp
+  ];
   description = "A quick webapp generator for any file processing tool";
   license = stdenv.lib.licenses.gpl3;
 }

quickwebapp.cabal

@@ -1,5 +1,5 @@
 name:                quickwebapp
-version:             2.1.1.0
+version:             3.0.0.0
 synopsis:            A quick webapp generator for any file processing tool
 description:
     A quick-and-dirty api generator, inspired from the 'interact' function from
@@ -29,9 +29,15 @@ source-repository head
 library
   exposed-modules:     QuickWebApp
   build-depends:       base ==4.*,
+                       containers,
                        bytestring,
                        text,
-                       http-types,
-                       scotty
-  -- hs-source-dirs:      src
+                       aeson,
+                       either,
+                       servant,
+                       servant-server,
+                       servant-lucid,
+                       lucid,
+                       warp
+
   default-language:    Haskell2010