urlpath 2.1.0 → 3.0.0
raw patch · 6 files changed
+180/−372 lines, 6 filesdep +path-extradep −QuickCheckdep −criteriondep −deepseqdep ~basesetup-changed
Dependencies added: path-extra
Dependencies removed: QuickCheck, criterion, deepseq, hspec, monoid-subclasses, quickcheck-instances, text, transformers, urlpath
Dependency ranges changed: base
Files
- Setup.hs +0/−2
- benchmarks/Main.hs +0/−13
- src/Data/Url.hs +175/−56
- src/Data/Url/Types.hs +0/−203
- test/Spec.hs +0/−1
- urlpath.cabal +5/−97
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− benchmarks/Main.hs
@@ -1,13 +0,0 @@-module Main where--import Criterion.Main-import qualified Data.Text as T-import TextBenchmarks (TextBenchmark (..), benchmarks)---- | Function to run the benchmarks using criterion-main :: IO ()-main = defaultMain $ map benchUrl benchmarks- where- benchUrl (TextBenchmark name f x) = bgroup name- [bench "Text" $ nf (T.length . f) x- ]
src/Data/Url.hs view
@@ -1,82 +1,201 @@ {-# LANGUAGE- OverloadedStrings+ KindSignatures , MultiParamTypeClasses- , FlexibleInstances- , FlexibleContexts- , KindSignatures- , InstanceSigs+ , FunctionalDependencies , TypeFamilies- , RankNTypes+ , TypeSynonymInstances+ , FlexibleInstances+ , DeriveFunctor #-} -module Data.Url- ( UrlReader (..)- , Url (..)- , module Data.Url.Types ) where+module Data.Url where -import Data.Url.Types+import Path.Extended -import Data.String-import Data.Monoid-import Data.Monoid.Textual (TextualMonoid)-import Control.Applicative-import Control.Monad+import Data.Functor.Identity import Control.Monad.Trans-import Control.Monad.Reader.Class+import Control.Monad.Reader + -- * Classes --- | @Url@ is a relationship between an underlying string type--- @plain@, and a deployment context @m@. We try to make the deployment style--- coercible at the top level - if the expression has a type--- @Url String (AbsoluteUrlT String Identity)@ or--- @Monad m => Url T.Text (GroundedUrlT LT.Text m)@ will force--- /all use-cases within the expression/ to coerce to that type.-class ( TextualMonoid plain- , MonadReader plain m- ) => Url plain (m :: * -> *) where- queryUrl :: QueryString plain -- ^ Url type, parameterized over a string type @plain@- -> m plain -- ^ Rendered Url in some context.- plainUrl :: plain -- ^ raw small string- -> m plain -- ^ Rendered string in some context.+class Url b (m :: * -> *) where+ pathUrl :: Path b t+ -> m String+ locUrl :: Location b t+ -> m String+ symbolUrl :: ( ToLocation s b t+ ) => s+ -> m String +instance ( Url b m+ , MonadTrans t+ , Monad m+ ) => Url b (t m) where+ pathUrl = lift . pathUrl+ locUrl = lift . locUrl+ symbolUrl = lift . symbolUrl --- | Overload deployment schemes with this - then, all that's needed is a type--- coercion to change deployment.-class Url plain m => UrlReader plain m where- type Result m :: * -> *- runUrlReader :: Url plain m =>- m b -- ^ MonadReader with index @string@ and result @b@- -> plain -- ^ Reader index- -> Result m b -- ^ Final result +-- | Make an instance for your own stringless route type to use your symbols+-- instead of strings or @Path@.+class ToLocation a b t | a -> b t where+ toLocation :: a -> Location b t -instance ( Monad m- , TextualMonoid plain ) => Url plain (RelativeUrlT plain m) where- queryUrl = RelativeUrlT . const . return . expandRelative- plainUrl x = RelativeUrlT $ const $ return $ expandRelative $ QueryString x [] Nothing+-- | Overload extraction for deployment transformers.+class UrlReader m where+ type RunUrlReader m :: * -> *+ runUrlReader :: m a -- ^ MonadReader with index @string@ and result @b@+ -> UrlAuthority -- ^ URI Scheme, hostname, and other details+ -> RunUrlReader m a -- ^ Final result ++-- * Types++-- | The hostname of a URL.+data UrlAuthority = UrlAuthority+ { urlScheme :: String+ , urlSlashes :: Bool+ , urlAuth :: Maybe UrlAuthent+ , urlHost :: String+ , urlPort :: Maybe Int+ } deriving (Eq, Ord)++instance Show UrlAuthority where+ show (UrlAuthority sh sl ma h mp) =+ sh ++ ":"+ ++ if sl then "//" else ""+ ++ maybe "" (\a -> show a ++ "@") ma+ ++ h+ ++ maybe "" (\p -> ":" ++ show p) mp++data UrlAuthent = UrlAuthent+ { urlAuthUser :: String+ , urlAuthPass :: Maybe String+ } deriving (Eq, Ord)++instance Show UrlAuthent where+ show (UrlAuthent u mp) = u ++ maybe "" (\p -> ":" ++ p) mp+++-- ** Relative Urls++newtype RelativeUrlT m a = RelativeUrlT+ { runRelativeUrlT :: UrlAuthority -> m a+ } deriving Functor++type RelativeUrl = RelativeUrlT Identity++instance Applicative m => Applicative (RelativeUrlT m) where+ pure x = RelativeUrlT $ const (pure x)+ f <*> x = RelativeUrlT $ \r ->+ (runRelativeUrlT f r) <*> (runRelativeUrlT x r)++instance Monad m => Monad (RelativeUrlT m) where+ return x = RelativeUrlT $ const (return x)+ m >>= f = RelativeUrlT $ \r ->+ runRelativeUrlT m r >>= (\x -> runRelativeUrlT (f x) r)++instance MonadTrans RelativeUrlT where+ lift = RelativeUrlT . const++-- | Returns the base that urls are appended to - @mempty@ instance ( Monad m- , TextualMonoid plain ) => UrlReader plain (RelativeUrlT plain m) where- type Result (RelativeUrlT plain m) = m+ ) => MonadReader String (RelativeUrlT m) where+ ask = return ""+ local _ x = x++instance MonadIO m => MonadIO (RelativeUrlT m) where+ liftIO = lift . liftIO++instance ( Applicative m+ ) => Url Rel (RelativeUrlT m) where+ pathUrl x = pure (toFilePath x)+ locUrl x = pure (show x)+ symbolUrl x = pure (show (toLocation x))++instance UrlReader (RelativeUrlT m) where+ type RunUrlReader (RelativeUrlT m) = m runUrlReader = runRelativeUrlT -instance ( Monad m- , TextualMonoid plain ) => Url plain (GroundedUrlT plain m) where- queryUrl = GroundedUrlT . const . return . expandGrounded- plainUrl x = GroundedUrlT $ const $ return $ expandGrounded $ QueryString x [] Nothing +-- ** Grounded Urls++newtype GroundedUrlT m a = GroundedUrlT+ { runGroundedUrlT :: UrlAuthority -> m a+ } deriving Functor++type GroundedUrl = GroundedUrlT Identity++instance Applicative m => Applicative (GroundedUrlT m) where+ pure x = GroundedUrlT $ const (pure x)+ f <*> x = GroundedUrlT $ \r ->+ (runGroundedUrlT f r) <*> (runGroundedUrlT x r)++instance Monad m => Monad (GroundedUrlT m) where+ return x = GroundedUrlT $ const (return x)+ m >>= f = GroundedUrlT $ \r ->+ runGroundedUrlT m r >>= (\x -> runGroundedUrlT (f x) r)++instance MonadTrans GroundedUrlT where+ lift = GroundedUrlT . const++-- | Returns the base that urls are appended to - @/@ instance ( Monad m- , TextualMonoid plain ) => UrlReader plain (GroundedUrlT plain m) where- type Result (GroundedUrlT plain m) = m+ ) => MonadReader String (GroundedUrlT m) where+ ask = return "/"+ local _ x = x++instance MonadIO m => MonadIO (GroundedUrlT m) where+ liftIO = lift . liftIO++instance ( Applicative m+ ) => Url Abs (GroundedUrlT m) where+ pathUrl x = pure (toFilePath x)+ locUrl x = pure (show x)+ symbolUrl x = pure (show (toLocation x))++instance UrlReader (GroundedUrlT m) where+ type RunUrlReader (GroundedUrlT m) = m runUrlReader = runGroundedUrlT -instance ( Monad m- , TextualMonoid plain ) => Url plain (AbsoluteUrlT plain m) where- queryUrl = expandAbsolute- plainUrl x = expandAbsolute $ QueryString x [] Nothing +-- ** Absolute Urls++newtype AbsoluteUrlT m a = AbsoluteUrlT+ { runAbsoluteUrlT :: UrlAuthority -> m a+ } deriving Functor++type AbsoluteUrl = AbsoluteUrlT Identity++instance Applicative m => Applicative (AbsoluteUrlT m) where+ pure x = AbsoluteUrlT $ const (pure x)+ f <*> x = AbsoluteUrlT $ \r ->+ (runAbsoluteUrlT f r) <*> (runAbsoluteUrlT x r)++instance Monad m => Monad (AbsoluteUrlT m) where+ return x = AbsoluteUrlT $ const (return x)+ m >>= f = AbsoluteUrlT $ \r ->+ runAbsoluteUrlT m r >>= (\x -> runAbsoluteUrlT (f x) r)++instance MonadTrans AbsoluteUrlT where+ lift = AbsoluteUrlT . const++-- | Returns the base that urls are appended to - the host instance ( Monad m- , TextualMonoid plain ) => UrlReader plain (AbsoluteUrlT plain m) where- type Result (AbsoluteUrlT plain m) = m+ ) => MonadReader UrlAuthority (AbsoluteUrlT m) where+ ask = AbsoluteUrlT return+ local f (AbsoluteUrlT g) = AbsoluteUrlT (g . f)++instance MonadIO m => MonadIO (AbsoluteUrlT m) where+ liftIO = lift . liftIO++instance ( Applicative m+ ) => Url Abs (AbsoluteUrlT m) where+ pathUrl x = AbsoluteUrlT (\h -> pure $ show h ++ toFilePath x)+ locUrl x = AbsoluteUrlT (\h -> pure $ show h ++ show x)+ symbolUrl x = AbsoluteUrlT (\h -> pure $ show h ++ show (toLocation x))++instance UrlReader (AbsoluteUrlT m) where+ type RunUrlReader (AbsoluteUrlT m) = m runUrlReader = runAbsoluteUrlT
− src/Data/Url/Types.hs
@@ -1,203 +0,0 @@-{-# LANGUAGE- GADTs- , BangPatterns- , OverloadedStrings- , FlexibleContexts- , FlexibleInstances- , MultiParamTypeClasses- , DeriveFunctor- #-}--module Data.Url.Types where--import Data.String-import Data.List-import Data.Monoid-import Data.Monoid.Textual (TextualMonoid)-import Data.Functor.Identity-import Control.Applicative-import Control.Monad-import Control.Monad.Trans-import Control.Monad.Reader.Class---- | Abstract data type for a Url - a "target" and GET parameters. We require @IsString@--- and @Monoid@ for generic construction, but rendering will require a monomorphic type.------ The type constructor is parameterized over it's underlying @IsString@ &--- @Monoid@ instance.-data QueryString a where- QueryString :: ( TextualMonoid a ) =>- a -- location- -> [(a, a)] -- query parameters- -> Maybe a -- hash- -> QueryString a---- | We can't provide a @Show@ instance for @QueryString@ because that would force--- us to use @String@.-showUrlString :: QueryString a- -> a-showUrlString (QueryString !t [] !mh) =- maybe t (\h -> t <> "#" <> h) mh-showUrlString (QueryString !t ((!k,!v):xs) !mh) =- let b = t <> "?" <> k <> "=" <> v <>- foldl (\acc (x,y) -> acc <> "&" <> x <> "=" <> y) "" xs- in- maybe b (\h -> b <> "#" <> h) mh----- | Makes a @QueryString@ out of a raw target path and a GET parameter pair.-(<?>) :: ( TextualMonoid a ) =>- a -- ^ Target string- -> (a, a) -- ^ GET Parameter- -> QueryString a-(<?>) !t !kv = QueryString t [kv] Nothing--infixl 9 <?>---- | Adds another GET parameter pair to a @QueryString@.-(<&>) :: ( TextualMonoid a ) =>- QueryString a -- ^ Old Url- -> (a, a) -- ^ Additional GET Parameter- -> QueryString a-(<&>) (QueryString !t !p _) !kv = QueryString t (p ++ [kv]) Nothing--infixl 8 <&>--class Hashable l r where- -- | Adds a hash parameter to a @QueryString@.- (<#>) :: l -> r -> QueryString r--instance ( TextualMonoid a ) => Hashable a a where- (<#>) t h = QueryString t [] $ Just h--instance ( TextualMonoid a ) => Hashable (QueryString a) a where- (<#>) (QueryString !t !p _) !h = QueryString t p $ Just h--infixl 7 <#>--fromRoute :: ( TextualMonoid a ) =>- ([a], [(a, a)])- -> QueryString a-fromRoute (l,qs) = QueryString (intercalate' "/" l) qs Nothing- where- intercalate' c [s] = s- intercalate' c (s:ss) = s <> c <> intercalate' c ss----- | Render the Url String flatly - without anything prepended to the target.-expandRelative :: ( TextualMonoid plain ) =>- QueryString plain- -> plain-expandRelative = showUrlString---- | Render the Url String as grounded - prepended with a "root" @//@ character.-expandGrounded :: ( TextualMonoid plain ) =>- QueryString plain- -> plain-expandGrounded !x = "/" <> showUrlString x---- | Render the Url String as absolute - getting the root from a @MonadReader@--- context.-expandAbsolute :: ( MonadReader plain m- , TextualMonoid plain ) =>- QueryString plain- -> m plain-expandAbsolute !x = do- host <- ask- return $ host <> "/" <> showUrlString x---- | Render the Url String as absolute, but with your own configuration type.------ > data SiteConfig = SiteConfig { host :: T.Text--- > , cdnHost :: T.Text--- > }--- > deriving (Show, Eq)--- >--- > foo :: HtmlT (Reader SiteConfig) ()--- > foo = do--- > url <- lift $ expandAbsoluteWith ("foo.php" <?> ("bar","baz")) host--- > script_ [src_ url] ""--- >--- > bar :: LT.Text--- > bar = (runReader (runTextT foo)) $--- > SiteConfig "example.com" "cdn.example.com"-expandAbsoluteWith :: ( MonadReader a m- , TextualMonoid plain ) =>- QueryString plain- -> (a -> plain)- -> m plain-expandAbsoluteWith !x f = do- root <- liftM f ask- return $ root <> "/" <> showUrlString x--newtype RelativeUrlT h m b = RelativeUrlT { runRelativeUrlT :: h -> m b }- deriving Functor--instance Applicative f => Applicative (RelativeUrlT h f) where- (<*>) f x = RelativeUrlT $ \a ->- (<*>) (runRelativeUrlT f a) (runRelativeUrlT x a)--instance Monad m => Monad (RelativeUrlT h m) where- return x = RelativeUrlT $ \_ -> return x- m >>= f = RelativeUrlT $ \a ->- runRelativeUrlT m a >>= (\x -> runRelativeUrlT (f x) a)--instance MonadTrans (RelativeUrlT h) where- lift = RelativeUrlT . const--instance ( Monad m- , IsString h ) => MonadReader h (RelativeUrlT h m) where- ask = return ""--instance MonadIO m => MonadIO (RelativeUrlT h m) where- liftIO = lift . liftIO--type RelativeUrl h b = RelativeUrlT h Identity b--newtype GroundedUrlT h m b = GroundedUrlT { runGroundedUrlT :: h -> m b }- deriving Functor--instance Applicative f => Applicative (GroundedUrlT h f) where- (<*>) f x = GroundedUrlT $ \a ->- (<*>) (runGroundedUrlT f a) (runGroundedUrlT x a)--instance Monad m => Monad (GroundedUrlT h m) where- return x = GroundedUrlT $ \_ -> return x- m >>= f = GroundedUrlT $ \a ->- runGroundedUrlT m a >>= (\x -> runGroundedUrlT (f x) a)--instance MonadTrans (GroundedUrlT h) where- lift = GroundedUrlT . const--instance ( Monad m- , IsString h ) => MonadReader h (GroundedUrlT h m) where- ask = return "/"--instance MonadIO m => MonadIO (GroundedUrlT h m) where- liftIO = lift . liftIO--type GroundedUrl h b = GroundedUrlT h Identity b--newtype AbsoluteUrlT h m b = AbsoluteUrlT { runAbsoluteUrlT :: h -> m b }- deriving Functor--instance Applicative f => Applicative (AbsoluteUrlT h f) where- (<*>) f x = AbsoluteUrlT $ \a ->- (<*>) (runAbsoluteUrlT f a) (runAbsoluteUrlT x a)--instance Monad m => Monad (AbsoluteUrlT h m) where- return x = AbsoluteUrlT $ const $ return x- m >>= f = AbsoluteUrlT $ \a ->- runAbsoluteUrlT m a >>= (\x -> runAbsoluteUrlT (f x) a)--instance MonadTrans (AbsoluteUrlT h) where- lift = AbsoluteUrlT . const--instance ( Monad m- , IsString h ) => MonadReader h (AbsoluteUrlT h m) where- ask = AbsoluteUrlT return--instance MonadIO m => MonadIO (AbsoluteUrlT h m) where- liftIO = lift . liftIO--type AbsoluteUrl h b = AbsoluteUrlT h Identity b
− test/Spec.hs
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
urlpath.cabal view
@@ -1,75 +1,12 @@ Name: urlpath-Version: 2.1.0+Version: 3.0.0 Author: Athan Clark <athan.clark@gmail.com> Maintainer: Athan Clark <athan.clark@gmail.com> License: MIT License-File: LICENSE Category: Web, Data-Synopsis: Painfully simple URL writing combinators-Description:- Simple URL DSL for Haskell.- .- This library tries to make it easier for people to write Url strings,- structurally. Packages like <https://hackage.haskell.org/package/yesod-routes Yesod Routes>- do a wonderful job at implementing string-free routing and- references, but sometimes we have to compromise. This tries to make that- compromise less painful.- .- Use bare combinators to render your strings (kinda useless):- .- > expandRelative $ "foo.php" <?> ("key1","bar") <&> ("key2","baz")- >- > ↪ "foo.php?key1=bar&key2=baz"- .- ... or use the MonadReader instance for a configurable host:- .- > let path = runAbsoluteUrl $ url $ "foo.php" <?> ("key1","bar") <&> ("key2","baz")- > path "example.com"- >- > ↪ "example.com/foo.php?key1=bar&key2=baz"- .- @url@ puts the @UrlString@ in a MonadReader that we can use for applying our- host. We use different monads for different deployment schemes (currently we- have 3 - @RelativeUrl@, @GroundedUrl@, and @AbsoluteUrl@), which we can- integrate in different libraries, like Lucid:- .- > (runAbsoluteUrl $ renderTextT $ do- > foo <- lift $ url $ "foo" <?> ("bar","baz")- > script_ [src_ foo] "" )- > ) "example.com"- >- > ↪ "<script src=\"example.com/foo?bar=baz\"></script>"- .- ... and in Scotty ...- .- > main :: IO ()- > main = scottyT 3000- > rootConf- > rootConf- > run- >- > where- > rootConf = flip runAbsoluteT "http://example.com"- >- > run :: ( MonadIO m- > , MonadReader T.Text m- > , Url T.Text m ) =>- > ScottyT LT.Text m ()- > run = get "/" $ do- > path <- lift $ url $ "foo" <?> ("bar","baz")- > text $ LT.fromStrict path- >- > λ> curl localhost:3000/- > ↪ "http://example.com/foo?bar=baz"- .- Note that in the scotty example, we don't use one of our deployment schemes -- this is because the @scottyT@ function expects it's underlying monad to be an- instance of @MonadIO@, which we can only instantiate in our monad transformers.- .- Please take mind - the string type underlying the Url rendering is generalized- to @Data.String.IsString@ for convenient use with @-XOverloadedStrings@. However,- due to that generality, we need to specify the monomorphic type (like- @Data.Text.Text@ above).+Synopsis: Painfully simple URL deployment.+-- Description: Cabal-Version: >= 1.10 Build-Type: Simple@@ -79,38 +16,9 @@ HS-Source-Dirs: src GHC-Options: -Wall Exposed-Modules: Data.Url- Data.Url.Types- Build-Depends: base >= 4 && < 5- , mtl- , transformers- , monoid-subclasses--Test-Suite spec- Type: exitcode-stdio-1.0- Default-Language: Haskell2010- Hs-Source-Dirs: src- , test- Ghc-Options: -Wall- Main-Is: Spec.hs- Build-Depends: base- , hspec- , QuickCheck- , quickcheck-instances+ Build-Depends: base >= 4.8 && < 5 , mtl- , text- , transformers- , monoid-subclasses--benchmark bench- type: exitcode-stdio-1.0- hs-source-dirs: benchmarks- main-is: Main.hs- build-depends: base- , deepseq- , criterion- , text- , urlpath >= 0.2- ghc-options: -O2+ , path-extra Source-Repository head Type: git