diff --git a/QuickWebApp.hs b/QuickWebApp.hs --- a/QuickWebApp.hs +++ b/QuickWebApp.hs @@ -1,88 +1,108 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-| 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'. +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +{-| A quick-and-dirty api generator, for any function @a -> "Either" "String" b@. + +If you only have a function @f :: a -> b@, simply run @interactWeb ("Right" .f)@ -} -module QuickWebApp where +module QuickWebApp ( + interactWeb + ) 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 +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 --- | Represents types which can be converted to a Lazy 'ByteString' -class ToLBS a where - toLBS :: a -> BL.ByteString +import Lucid +import Servant +import Servant.HTML.Lucid -instance ToLBS BL.ByteString where - toLBS = id +type API = Get '[HTML] Home + :<|> ReqBody '[JSON, FormUrlEncoded] Input :> Post '[JSON] Output -instance ToLBS BS.ByteString where - toLBS = BL.fromStrict -instance ToLBS TL.Text where - toLBS = TL.encodeUtf8 +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=\"\"" + kbd_ "curl localhost:8080 -d input=\"\"" + 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 -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 +newtype Input = Input { input :: Text } deriving (Show, Eq, Generic) -instance FromLBS TS.Text where - fromLBS = TL.toStrict . TL.decodeUtf8 +instance FromJSON Input +instance FromFormUrlEncoded Input where + fromFormUrlEncoded = eitherDecode . encode . M.fromList -instance FromLBS String where - fromLBS = BC.unpack +newtype Output = Output { output :: Text } deriving (Show, Eq, Generic) +instance ToJSON Output --- | Unprocessable entity error code (temporary fix for a missing status in --- http-types) -err422 :: Status -err422 = mkStatus 422 "Unprocessable Entity" +{-| Tranform a function into a webapp. +The inputs and outputs must implement 'FromText' and 'ToText', respectively. --- | Equivalent to 'interactWebOn 3000' -interactWeb :: (FromLBS a, ToLBS b) => (a -> b) -> IO () -interactWeb = interactWebOn 3000 +You can query it via a browser at or by using +curl/httpie --- | Equivalent to 'interactWebEitherOn 3000' -interactWebEither :: (FromLBS a, ToLBS b, ToLBS e) => (a -> Either e b) -> IO () -interactWebEither = interactWebEitherOn 3000 + > http :8080 input="" --- | 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 + > curl localhost:8080 -d input="" +-} +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 --- | 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) +err :: String -> ServantErr +err e = ServantErr 422 "Unprocessable Entity" (BL8.pack (show e)) [] diff --git a/quickwebapp.cabal b/quickwebapp.cabal --- a/quickwebapp.cabal +++ b/quickwebapp.cabal @@ -1,5 +1,5 @@ name: quickwebapp -version: 2.1.1.0 +version: 3.0.0.1 synopsis: A quick webapp generator for any file processing tool description: A quick-and-dirty api generator, inspired from the 'interact' function from @@ -7,7 +7,7 @@ . > interactWeb reverse . - This creates a server listening on port 3000. + This creates a server listening on port 8080, or environment value PORT. . license: GPL-3 license-file: LICENSE @@ -29,9 +29,15 @@ 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