packages feed

hexpress (empty) → 0.1.0.0

raw patch · 9 files changed

+454/−0 lines, 9 filesdep +aesondep +basedep +binarysetup-changed

Dependencies added: aeson, base, binary, bytestring, case-insensitive, filepath, http-types, mime-types, mtl, text, transformers, vault, wai, warp

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for hexpress++## 0.1.0.0  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2017 Alec Snyder++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,4 @@+# Hexpress+Hex is an express-like web framework for Haskell written by allonsy.+This is still a WIP although you can check out `hello.hs` for an example+cabal packages and libraries are coming soon.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hexpress.cabal view
@@ -0,0 +1,45 @@+-- Initial hexpress.cabal generated by cabal init.  For further+-- documentation, see http://haskell.org/cabal/users-guide/++name:                hexpress+version:             0.1.0.0+synopsis:            An express-like http framework+description:         Hexpress is an express like http framework to make it easy to write http servers. It is built on the warp http and is blazing fast. See the github readme for more information.+homepage:            https://github.com/allonsy/hexpress+license:             MIT+license-file:        LICENSE+author:              Alec Snyder+maintainer:          linuxbash8@gmail.com+-- copyright:+category:            Network+build-type:          Simple+extra-source-files:  ChangeLog.md, README.md+cabal-version:       >=1.10++Source-Repository head+  Type:     git+  Location: git://github.com/allonsy/hexpress.git++library+  exposed-modules:     Network.Hexpress.Request,+                       Network.Hexpress.Server,+                       Network.Hexpress.Types,+                       Network.Hexpress.Middleware.Router+  -- other-modules:+  -- other-extensions:+  build-depends:       base >=4.10 && <4.11,+                       bytestring >=0.10 && <1.0.0,+                       transformers >=0.5 && <1.0.0,+                       filepath >=1.0 && <2.0.0,+                       binary >=0.8 && <1.0.0,+                       mtl >=2.0.0 && <3.0.0,+                       http-types >= 0.8.0 && <1.0.0,+                       wai >= 3.0.0 && <4.0.0,+                       aeson >= 1.0.0 && <2.0.0,+                       vault >= 0.3.0.0 && <1.0.0,+                       text >= 1.0.0 && <2.0.0,+                       warp >= 3.0.0 && <4.0.0,+                       mime-types >= 0.1.0.0 && <1.0.0,+                       case-insensitive >= 1.0.0 && <2.0.0+  hs-source-dirs:      src+  default-language:    Haskell2010
+ src/Network/Hexpress/Middleware/Router.hs view
@@ -0,0 +1,132 @@+module Network.Hexpress.Middleware.Router (+Method(..)+, router+, standaloneRouter+) where++import qualified Data.ByteString.Char8 as SB+import qualified Data.Text as TXT+import Network.Hexpress.Types+import Network.Hexpress.Request+import Network.Hexpress.Server+import Network.HTTP.Types.URI+import Network.HTTP.Types.Status++data Method = GET+  | HEAD+  | POST+  | PUT+  | DELETE+  | CONNECT+  | OPTIONS+  | TRACE+  | PATCH+  deriving (Eq)++methodToString :: Method -> String+methodToString GET = "GET"+methodToString POST = "POST"+methodToString PUT = "PUT"+methodToString PATCH = "PATCH"+methodToString DELETE = "DELETE"+methodToString HEAD = "HEAD"+methodToString CONNECT = "CONNECT"+methodToString OPTIONS = "OPTIONS"+methodToString TRACE = "TRACE"++stringToMethod :: String -> Method+stringToMethod "GET" = GET+stringToMethod "POST" = POST+stringToMethod "PUT" = PUT+stringToMethod "PATCH" = PATCH+stringToMethod "DELETE" = DELETE+stringToMethod "HEAD" = HEAD+stringToMethod "CONNECT" = CONNECT+stringToMethod "OPTIONS" = OPTIONS+stringToMethod "TRACE" = TRACE++emptyText :: TXT.Text+emptyText = TXT.pack ""++starText :: TXT.Text+starText = TXT.pack "*"++isColon :: TXT.Text -> Bool+isColon str = TXT.head str == ':'++byteStringToMethod :: SB.ByteString -> Method+byteStringToMethod bs = stringToMethod $ SB.unpack bs++stringToPath :: String -> [TXT.Text]+stringToPath str = decodePathSegments $ SB.pack str++type Route a b = (Method, [TXT.Text], (a -> Server b))++extractRtPath :: Route a b -> [TXT.Text]+extractRtPath (_, p, _) = p++isEmpty :: [a] -> Bool+isEmpty [] = True+isEmpty _ = False++isMatch :: [TXT.Text] -> Route a b -> Bool+isMatch [] (_, [], _) = True+isMatch [] (_,(x:xs),_) = False+isMatch (y:ys) (_, [], _) = False+isMatch (y:ys) (m,(x:xs),fn)+  | x == emptyText || x == starText = True+  | isColon x = isMatch ys (m,xs,fn)+  | x == y = isMatch ys (m,xs,fn)+  | otherwise = False++isMethodMatch :: Method -> Route a b -> Bool+isMethodMatch targetMeth (meth, _, _) = meth == targetMeth++-- assumes non empty+getLast :: [a] -> a+getLast [x] = x+getLast (x:xs) = getLast xs++isExact :: Route a b -> Bool+isExact (_, [], _) = True+isExact (m, (x:xs), fn)+  | x == starText || x == emptyText || isColon x = False+  | otherwise = isExact (m, xs, fn)++findLongest :: Int -> [Route a b] -> [Route a b] -> Route a b+findLongest largest ls [] = getLast ls+findLongest largest ls (rt@(m,x,fn):xs)+  | isExact rt = rt+  | length x > largest = findLongest (length x) [rt] xs+  | length x == largest = findLongest largest (rt:ls) xs+  | otherwise = findLongest largest ls xs++router :: [(Method, String, a -> Server b)] -> (a -> Server b)+router rts arg = routerHelper where+  preprocessed = map (\(m, str, fn) -> (m, stringToPath str, fn)) rts+  routerHelper = do+    path <- getPath+    let matches = filter (isMatch path) preprocessed+    if isEmpty matches then notFound arg+    else do+      meth <- getMethod+      let targetMeth = byteStringToMethod meth+      let methMatches = filter (isMethodMatch targetMeth) matches+      if isEmpty methMatches then notAllowed arg+      else do+        let (_, _, fn) = findLongest (-1) [] methMatches+        fn arg+++notFound :: a -> Server b+notFound _ = do+  setStatus status404+  end++notAllowed :: a -> Server b+notAllowed _ = do+  setStatus status405+  end++standaloneRouter :: [(Method, String, Server a)] -> Server a+standaloneRouter rts = (router $ map (\(meth, rt, handler) -> (meth, rt, \() -> handler)) rts) ()
+ src/Network/Hexpress/Request.hs view
@@ -0,0 +1,53 @@+module Network.Hexpress.Request where++import Network.Wai+import Network.HTTP.Types+import Network.Hexpress.Types+import Data.Text+import Data.Vault.Lazy+import Data.ByteString.Lazy.Char8 as LB+import Data.ByteString.Char8 as SB+import Data.Aeson as Aeson++getQueryString :: Server Query+getQueryString = do+  req <- getRequest+  return $ queryString req++getPath :: Server [Text]+getPath = do+  req <- getRequest+  return $ pathInfo req++getMethod :: Server Method+getMethod = do+  req <- getRequest+  return $ requestMethod req++getHeaders :: Server [Header]+getHeaders = do+  req <- getRequest+  return $ requestHeaders req++getVault :: Server Vault+getVault = do+  req <- getRequest+  return $ vault req++getBodyLazy :: Server LB.ByteString+getBodyLazy = do+  req <- getRequest+  performIO $ lazyRequestBody req++getBodyStrict :: Server LB.ByteString+getBodyStrict = do+  req <- getRequest+  performIO $ strictRequestBody req++getJSONObj :: Server (Maybe Aeson.Value)+getJSONObj = getJSON++getJSON :: FromJSON a => Server (Maybe a)+getJSON = do+  body <- getBodyLazy+  return $ Aeson.decode body
+ src/Network/Hexpress/Server.hs view
@@ -0,0 +1,122 @@+module Network.Hexpress.Server+( addCustomHeader+, setMimeType+, sendString+, sendJSON+, sendJSONLiteral+, end+, debugLog+, staticFile+, staticFileCached+, staticDir+, run+, runEnv+, runSettings+) where++import Network.Hexpress.Types+import Network.Hexpress.Request+import Data.CaseInsensitive as CI+import Network.HTTP.Types.Status+import Network.HTTP.Types.Header+import Data.ByteString.Lazy.Char8 as LB+import Data.ByteString.Char8 as SB+import Control.Monad.IO.Class+import Control.Monad.Trans.Maybe+import Data.Aeson as Aeson+import Data.Text as TXT+import Network.HTTP.Types.URI+import Network.Mime+import qualified Network.Wai.Handler.Warp as WAI+import System.FilePath+import Data.Maybe+import Control.Exception (catch, IOException)++addCustomHeader :: (SB.ByteString, SB.ByteString) -> Server ()+addCustomHeader (name, contents) = addHeader (CI.mk name, contents)++setMimeType :: SB.ByteString -> Server ()+setMimeType mtype = do+  addHeader (hContentType, mtype)++sendJSONLiteral :: Aeson.Value -> Server ()+sendJSONLiteral = sendJSON++sendJSON :: ToJSON a => a -> Server ()+sendJSON obj = do+  setMimeType (SB.pack "application/json")+  setStatus status200+  sendByteString (Aeson.encode obj)++sendString :: String -> Server ()+sendString str = do+  sendByteString $ LB.pack str++end :: Server a+end = MaybeT (return Nothing)++debugLog :: String -> Server ()+debugLog str = liftIO $ Prelude.putStrLn str++stringToPath :: String -> [TXT.Text]+stringToPath str = decodePathSegments $ SB.pack str++handleFileError :: IOException -> IO (Maybe a)+handleFileError _ = return Nothing++staticFile :: String -> SB.ByteString -> Server ()+staticFile fname mime = do+  setMimeType mime+  setStatus status200+  contents <- liftIO $ catch (LB.readFile fname >>= (\cont -> return (Just cont))) handleFileError+  case contents of Nothing       -> notFound ()+                   Just contents -> sendByteString contents++staticFileCached :: String -> SB.ByteString -> IO (Server ())+staticFileCached fname mime = do+  contents <- LB.readFile fname+  let serv = addHeader (hContentType, mime) >>+             setStatus status200 >>+             sendByteString contents+  return serv++getfname :: [TXT.Text] -> [TXT.Text] -> Maybe [TXT.Text]+getfname [] path = Just path+getfname (x:xs) [] = Nothing+getfname (x:xs) (y:ys)+  | xs == [] && x == TXT.empty = Just (y:ys)+  | x == y = getfname xs ys+  | otherwise = Nothing++staticDir :: String -> String -> Server ()+staticDir prefix location = staticDirHelper where+  prefixPath = stringToPath prefix+  locationPath = stringToPath location+  staticDirHelper = do+    path <- getPath+    let localname = getfname prefixPath path+    if localname == Nothing then notFound ()+    else do+      let fname = joinPath $ Prelude.map TXT.unpack (locationPath ++ fromJust localname)+      let mtype = defaultMimeLookup (TXT.pack fname)+      staticFile fname mtype++notFound :: a -> Server b+notFound _ = do+  setStatus status404+  end++run :: Int -> Server () -> IO ()+run port srv = do+  app <- serverToApp srv+  WAI.run port app++runEnv :: Int -> Server () -> IO ()+runEnv port srv = do+  app <- serverToApp srv+  WAI.runEnv port app++runSettings :: WAI.Settings -> Server () -> IO ()+runSettings settings srv = do+  app <- serverToApp srv+  WAI.runSettings settings app
+ src/Network/Hexpress/Types.hs view
@@ -0,0 +1,71 @@+module Network.Hexpress.Types+( Server+, Middleware+, passthrough+, serverToApp+, addHeader+, sendByteString+, setStatus+, getRequest+, performIO+) where++import qualified Network.Wai as WAI+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.State.Lazy+import Data.ByteString.Lazy.Char8 as LB+import Data.ByteString.Char8 as SB+import Network.HTTP.Types.Status+import Network.HTTP.Types.Header+import Control.Monad.State.Class as ST+import Control.Monad.IO.Class+import Data.Binary.Builder as Builder++data ServerState = ServerState {+  req :: WAI.Request,+  toSend :: Builder,+  responseStatus :: Status,+  headers :: [Header]+}++type ServerIO = StateT ServerState IO++type Server = MaybeT ServerIO+type Middleware a b = a -> Server b++passthrough :: Server a -> (b -> Server b)+passthrough srv = \val -> srv >> return val++addHeader :: (HeaderName, SB.ByteString) -> Server ()+addHeader hd = do+  st <- ST.get+  let newST = st {headers=(headers st) ++ [hd]}+  ST.put newST++sendByteString :: LB.ByteString -> Server ()+sendByteString str = do+  st <- ST.get+  let newStr = Builder.fromLazyByteString str+  let newSt = st {toSend=Builder.append (toSend st) newStr}+  ST.put newSt++setStatus :: Status -> Server ()+setStatus stat = do+  st <- ST.get+  let newST = st {responseStatus=stat}+  ST.put newST++getRequest :: Server WAI.Request+getRequest = do+  st <- ST.get+  return $ req st++performIO :: IO a -> Server a+performIO ioact = liftIO ioact++serverToApp :: Server () -> IO WAI.Application+serverToApp serv = return $ \request resp -> do+  let st = runMaybeT serv -- ServerIO type+  endState <- execStateT st (ServerState request Builder.empty status200 [])+  let responseString = Builder.toLazyByteString $ toSend endState+  resp $ WAI.responseLBS (responseStatus endState) (headers endState) responseString