gemini-router (empty) → 0.1.0.0

raw patch · 6 files changed

+246/−0 lines, 6 filesdep +basedep +gemini-serverdep +network-urisetup-changed

Dependencies added: base, gemini-server, network-uri, transformers

Files

CHANGELOG.md +6/−0
LICENSE +30/−0
Network/Gemini/Router.hs +164/−0
README.md +9/−0
Setup.hs +2/−0
gemini-router.cabal +35/−0

+ CHANGELOG.md view

@@ -0,0 +1,6 @@+# Revision history for gemini-router++## 0.1.0.0 -- 2020-07-24++* First version. Released on an unsuspecting world.+

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2020, Francesco Gazzetta++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 Francesco Gazzetta 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.

+ Network/Gemini/Router.hs view

@@ -0,0 +1,164 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+module Network.Gemini.Router (+-- * The Route monad transformer+  RouteT+, Route+, RouteIO+-- * Running Routes+, runRouteT+, runRouteT'+-- * Building Routes+, end+, dir+, capture+, input+, optionalInput+, custom+-- * Getters+, getRequest+, getPath+) where++import Network.Gemini.Server++import Data.Maybe (fromMaybe)++import Data.Functor.Identity (Identity)+import Control.Applicative (Alternative(..))+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.IO.Class (MonadIO(..))++import Network.URI (uriQuery, pathSegments, unEscapeString)++#if __GLASGOW_HASKELL__ < 808+import Control.Monad.Fail (MonadFail(..))+#endif+++-- The RouteT monad transformer+-------------------------------++-- | Represents a way of routing requests through different handlers+newtype RouteT m a = RouteT { runRouteT :: Request -> [String] -> m (Maybe a) }++type Route = RouteT Identity+type RouteIO = RouteT IO++instance Functor f => Functor (RouteT f) where+  fmap f r = RouteT $ \req path -> fmap f <$> runRouteT r req path++instance Applicative f => Applicative (RouteT f) where+  pure x = RouteT $ \_ _ -> pure $ pure x+  f <*> x = RouteT $ \req path ->+    fmap (<*>) (runRouteT f req path) <*> runRouteT x req path++instance Monad m => Monad (RouteT m) where+  rx >>= f = RouteT $ \req path -> do+    mx <- runRouteT rx req path+    runRouteT (maybe (RouteT $ \_ _ -> pure Nothing) f mx) req path++instance MonadTrans RouteT where+  lift = RouteT . const . const . fmap pure++instance MonadIO m => MonadIO (RouteT m) where+  liftIO = RouteT . const . const . fmap pure . liftIO++-- TODO all other transformers instances++instance Monad m => MonadFail (RouteT m) where+  --TODO or maybe we shoudl just throw an exception+  --or is it possible to somehow directly return Response 42 err mempty? it would require early return... like happstack+  fail _ = empty++-- | 'empty' skips to the next route.+-- @r1 '<|>' r2@ means go to @r2@ if @r1@ skips+instance Monad f => Alternative (RouteT f) where+  empty = RouteT $ \_ _ -> pure Nothing+  r1 <|> r2 = RouteT $ \req path -> do+    maybe1 <- runRouteT r1 req path+    maybe2 <- runRouteT r2 req path+    pure $ maybe1 <|> maybe2++-- Running routes+-------------------------------++-- MAYBE swap names with runRouteT+-- | Given a @run@ function for the inner 'Monad', make a 'Handler'+runRouteT' :: (m (Maybe Response) -> IO (Maybe Response)) -- ^ Inner @run@+           -> RouteT m Response+           -> Handler+runRouteT' runM r req = fromMaybe notFound <$> runM (runRouteT r req path)+  where+    notFound = Response 51 "Not found" mempty+    path = unEscapeString <$> pathSegments req++-- Building Routes+-------------------------------++-- | Match on the end of the path+end :: Applicative f+    => RouteT f a -- ^ Route to run+    -> RouteT f a+end r = RouteT $ \req path -> case path of+  [] -> runRouteT r req path+  _ -> pure Nothing++-- | Match on a specific path segment+dir :: Applicative f+    => String -- ^ What the segment must match+    -> RouteT f a -- ^ Route to run on the rest of the path+    -> RouteT f a+dir str r = RouteT $ \req path -> case path of+  frag:rest | frag == str -> runRouteT r req rest+  _                       -> pure Nothing++-- TODO use a parsing class+-- | Match on an arbitrary path segment, and capture it+capture :: Applicative f+        => (String -> RouteT f a) -- ^ Function that takes the segment and+                                  -- returns the route to run on the rest of+                                  -- the path+        -> RouteT f a+capture f = RouteT $ \req path -> case path of+  frag:rest -> runRouteT (f frag) req rest+  _         -> pure Nothing++-- TODO use a parsing class+-- | Require a query string, by asking the client (code 10) if necessary+input :: Applicative f+      => String -- ^ String to return to the client if there is no query string+      -> (String -> RouteT f Response) -- ^ Function that takes the query string+                                       -- and returns the route to run on the+                                       -- rest of the path+      -> RouteT f Response+input q f = RouteT $ \req path -> case uriQuery req of+  '?':query -> runRouteT (f $ unEscapeString query) req path+  _         -> pure $ pure $ Response 10 q mempty++-- | Capture, if present, the query string+optionalInput :: Applicative f+              => (Maybe String -> RouteT f a) -- ^ Function that takes the+                                              -- query string (if present) and+                                              -- returns the route to run on+                                              -- the rest of the path+              -> RouteT f a+optionalInput f = RouteT $ \req path -> case uriQuery req of+  '?':query -> runRouteT (f $ Just $ unEscapeString query) req path+  _         -> runRouteT (f Nothing)                       req path++-- | Build custom routes. Takes a function that takes the request and the+-- remaining path segments and returns the result. A 'Nothing' makes the+-- request fall through to the next route+custom :: (Request -> [String] -> m (Maybe a)) -> RouteT m a+custom = RouteT++-- Getters+-------------------------------++getRequest :: Applicative m => RouteT m Request+getRequest = RouteT $ \req _ -> pure $ Just req++getPath :: Applicative m => RouteT m [String]+getPath = RouteT $ \_ path -> pure $ Just path+

+ README.md view

@@ -0,0 +1,9 @@+# gemini-router++[![Hackage](https://img.shields.io/hackage/v/gemini-router.svg)](https://hackage.haskell.org/package/gemini-router)+[![builds.sr.ht status](https://builds.sr.ht/~fgaz/gemini-router.svg)](https://builds.sr.ht/~fgaz/gemini-router?)++**A simple Happstack-style Gemini router**++More info at https://sr.ht/~fgaz/haskell-gemini/+

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ gemini-router.cabal view

@@ -0,0 +1,35 @@+cabal-version:       2.2++name:                gemini-router+version:             0.1.0.0+synopsis:            A simple Happstack-style Gemini router+description:+  This package contains a 'Router' monad transformer that works on top of the+  gemini-server package, with a functional+monadic+alternative interface,+  similar to Happstack. With it you can define gemini endpoints, capture parts+  of the request, and pass the requests to specific handlers.+homepage:            https://sr.ht/~fgaz/haskell-gemini/+bug-reports:         https://todo.sr.ht/~fgaz/haskell-gemini+license:             BSD-3-Clause+license-file:        LICENSE+author:              Francesco Gazzetta+maintainer:          Francesco Gazzetta <fgaz@fgaz.me>+copyright:           © 2020 Francesco Gazzetta and contributors+category:            Gemini+extra-source-files:  CHANGELOG.md, README.md++source-repository head+  type:                git+  location:            https://git.sr.ht/~fgaz/gemini-router++library+  exposed-modules:     Network.Gemini.Router+  -- other-modules:+  other-extensions:    FlexibleInstances, CPP+  build-depends:       base ^>=4.13.0.0 || ^>=4.14.0.0+                     , gemini-server ^>=0.1.0.0+                     , transformers ^>=0.5.6.2+                     , network-uri ^>=2.6.3.0 || ^>=2.7.0.0+  -- hs-source-dirs:+  default-language:    Haskell2010+