urlpath 9.0.1 → 10.0.0
raw patch · 3 files changed
+191/−267 lines, 3 filesdep ~attoparsec-uridep ~monad-control-aligneddep ~path
Dependency ranges changed: attoparsec-uri, monad-control-aligned, path, path-extra
Files
- README.md +0/−93
- src/Data/Url.hs +179/−162
- urlpath.cabal +12/−12
README.md view
@@ -1,93 +0,0 @@-# urlpath--[](https://travis-ci.org/athanclark/urlpath)-[](https://coveralls.io/r/athanclark/urlpath)-[](https://gitter.im/athanclark/urlpath)-[](https://tldrlegal.com/license/mit-license)-[](https://hackage.haskell.org/package/urlpath)-[](https://waffle.io/athanclark/urlpath)--Dirt-simple, embarrassing, horribly unimaginative URL combinator library for -Haskell.---## Installation--```bash-λ> cabal install urlpath-```--## Usage--You can use the combinators purely, if you're into that:---```haskell-λ> expandRelative $ "foo.php" <?> ("key1","bar") <&> ("key2","baz")--↪ "foo.asp?key1=bar&key2=baz"-```--Or you can use them with a configurable root, via the Reader monad:--```haskell-λ> runReader- (runAbsoluteUrl $ url $ "foo.asp" <?> ("key1","bar") <&> ("key2","baz"))- "http://example.com"--↪ "http://example.com/foo.asp?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 - `RelativeUrlT`, `GroundedUrlT`, and `AbsoluteUrlT`), which we can⋅-integrate in different libraries, like Lucid:--```haskell-λ> (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:--```haskell-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"-```--## How to run tests--```bash-λ> cabal install hspec --enable-tests && cabal test --show-details=always-```--## Contributing--I would prefer it that any inquiries and questions go to the-[Gitter Chat room](https://gitter.im/athanclark/urlpath), while any suggestions, -complaints, or requests go in the-[GitHub Issues](https://github.com/athanclark/urlpath/issues) /-[Waffle Dashboard](https://waffle.io/athanclark/urlpath). All ideas are welcome! -(Except really gross ones. I've got limits.)
src/Data/Url.hs view
@@ -1,17 +1,18 @@-{-# LANGUAGE- TypeFamilies- , DeriveFunctor- , KindSignatures- , OverloadedStrings- , OverloadedLists- , QuasiQuotes- , FlexibleInstances- , StandaloneDeriving- , TypeSynonymInstances- , UndecidableInstances- , MultiParamTypeClasses- , GeneralizedNewtypeDeriving- #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-} -- | -- Module : Data.Url@@ -33,165 +34,171 @@ module Data.Url where -import Path (Path, Abs, File, Dir, parseAbsDir, parseRelFile, toFilePath, absdir, (</>))-import Path.Extended (Location (..), fromAbsDir, fromAbsFile, (<&>), setFragment, getFragment, getQuery)+import Path (Abs, Path, Rel, absdir,+ parseAbsDir, parseRelDir,+ parseRelFile, toFilePath,+ (</>))+import Path.Extended (Location (..),+ LocationPath,+ printLocation,+ setFragment, (<&>))+import qualified Path.Extended as Path -import Data.Functor.Identity (Identity (..))-import Data.Functor.Compose (Compose)-import Data.Maybe (maybe)-import Data.URI (URI (..))-import Data.URI.Auth (URIAuth (..))-import Data.URI.Auth.Host (URIAuthHost (Localhost))-import qualified Data.Strict.Maybe as Strict-import qualified Data.Strict.Tuple as Strict-import qualified Data.Vector as V-import Data.List.Split (splitOn)-import qualified Data.Text as T-import Control.Applicative (Alternative ((<|>), empty))-import Control.Monad (MonadPlus ())-import Control.Monad.Fix (MonadFix ())-import Control.Monad.Base (MonadBase (liftBase), liftBaseDefault)-import Control.Monad.Catch (MonadMask (uninterruptibleMask, mask, generalBracket), MonadCatch (catch), MonadThrow (throwM), ExitCase (ExitCaseSuccess))-import Control.Monad.Cont (MonadCont (callCC), ContT)-import Control.Monad.Trans.Error (Error, ErrorT)-import Control.Monad.Except (MonadError (catchError, throwError), ExceptT)-import Control.Monad.Trans (MonadTrans (lift))-import Control.Monad.Trans.Control (MonadBaseControl (liftBaseWith, restoreM, StM), MonadTransControl (liftWith, restoreT, StT), ComposeSt, defaultRestoreM, defaultLiftBaseWith)+import Control.Applicative (Alternative (empty, (<|>)))+import Control.Monad (MonadPlus)+import Control.Monad.Base (MonadBase (liftBase),+ liftBaseDefault)+import Control.Monad.Catch (ExitCase (ExitCaseSuccess),+ MonadCatch (catch),+ MonadMask (generalBracket, mask, uninterruptibleMask),+ MonadThrow (throwM))+import Control.Monad.Cont (ContT, MonadCont (callCC))+import Control.Monad.Except (ExceptT,+ MonadError (catchError, throwError))+import Control.Monad.Fix (MonadFix)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.List (ListT)+import Control.Monad.Logger (LoggingT,+ MonadLogger (monadLoggerLog),+ NoLoggingT)+import Control.Monad.Morph (MFunctor (hoist),+ MMonad (embed))+import Control.Monad.Reader (MonadReader (ask, local),+ ReaderT)+import Control.Monad.RWS (MonadRWS, RWST)+import Control.Monad.State (MonadState (get, put),+ StateT)+import Control.Monad.Trans (MonadTrans (lift))+import Control.Monad.Trans.Control (ComposeSt,+ MonadBaseControl (StM, liftBaseWith, restoreM),+ MonadTransControl (StT, liftWith, restoreT),+ defaultLiftBaseWith,+ defaultRestoreM) import qualified Control.Monad.Trans.Control.Aligned as Aligned-import Control.Monad.Trans.Identity (IdentityT)-import Control.Monad.Trans.Maybe (MaybeT)-import Control.Monad.List (ListT)-import Control.Monad.IO.Class (MonadIO (liftIO))-import Control.Monad.Reader (MonadReader (ask, local), ReaderT)-import Control.Monad.Writer (MonadWriter (pass, listen, tell), WriterT)-import Control.Monad.State (MonadState (put, get), StateT)-import Control.Monad.RWS (MonadRWS, RWST)-import Control.Monad.Logger (MonadLogger (monadLoggerLog), NoLoggingT, LoggingT)-import Control.Monad.Trans.Resource (MonadResource (liftResourceT), ResourceT)-import Control.Monad.Morph (MMonad (embed), MFunctor (hoist))-import System.IO.Unsafe (unsafePerformIO)-import Unsafe.Coerce (unsafeCoerce)+import Control.Monad.Trans.Error (Error, ErrorT)+import Control.Monad.Trans.Identity (IdentityT)+import Control.Monad.Trans.Maybe (MaybeT)+import Control.Monad.Trans.Resource (MonadResource (liftResourceT),+ ResourceT)+import Control.Monad.Writer (MonadWriter (listen, pass, tell),+ WriterT)+import Data.Functor.Compose (Compose)+import Data.Functor.Identity (Identity (..))+import Data.List.Split (splitOn)+import qualified Data.Strict.Maybe as Strict+import qualified Data.Strict.Tuple as Strict+import qualified Data.Text as T+import Data.URI (URI (..), printURI)+import qualified Data.URI as URI+import Data.URI.Auth (URIAuth (..))+import Data.URI.Auth.Host (URIAuthHost (Localhost))+import qualified Data.Vector as V+import System.IO.Unsafe (unsafePerformIO)+import Unsafe.Coerce (unsafeCoerce) -- * Classes --- | Turns a @Path@ or @Location@ into a @String@, where the rendering behavior+-- | Turns a 'Path' or 'Location' into a 'String', where the rendering behavior -- (relative, grounded and absolute) is encoded in the monad you use, much like -- @LoggingT@ and @NoLoggingT@ from <https://hackage.haskell.org/package/monad-logger monad-logger>.-class MonadUrl (m :: * -> *) where- absDirUrl :: Path Abs Dir- -> m URI- absFileUrl :: Path Abs File- -> m URI- locUrl :: Location- -> m URI+class MonadUrl (m :: * -> *) base | m -> base where+ -- | Create a 'URL' from a 'Location' - either a directory or file, and can include query strings+ -- & fragments.+ locToUrl :: Location base -> m URL -instance MonadUrl IO where- absDirUrl = pure . mkUriLocEmpty . fromAbsDir- absFileUrl = pure . mkUriLocEmpty . fromAbsFile- locUrl = pure . mkUriLocEmpty+-- | Treated as relative urls+instance MonadUrl IO Rel where+ locToUrl = pure . RelURL -instance ( MonadUrl m+instance ( MonadUrl m base , Monad m- ) => MonadUrl (MaybeT m) where- absDirUrl = lift . absDirUrl- absFileUrl = lift . absFileUrl- locUrl = lift . locUrl+ ) => MonadUrl (MaybeT m) base where+ locToUrl = lift . locToUrl -instance ( MonadUrl m+instance ( MonadUrl m base , Monad m- ) => MonadUrl (ListT m) where- absDirUrl = lift . absDirUrl- absFileUrl = lift . absFileUrl- locUrl = lift . locUrl+ ) => MonadUrl (ListT m) base where+ locToUrl = lift . locToUrl -instance ( MonadUrl m+instance ( MonadUrl m base , Monad m- ) => MonadUrl (ResourceT m) where- absDirUrl = lift . absDirUrl- absFileUrl = lift . absFileUrl- locUrl = lift . locUrl+ ) => MonadUrl (ResourceT m) base where+ locToUrl = lift . locToUrl -instance ( MonadUrl m+instance ( MonadUrl m base , Monad m- ) => MonadUrl (IdentityT m) where- absDirUrl = lift . absDirUrl- absFileUrl = lift . absFileUrl- locUrl = lift . locUrl+ ) => MonadUrl (IdentityT m) base where+ locToUrl = lift . locToUrl -instance ( MonadUrl m+instance ( MonadUrl m base , Monad m- ) => MonadUrl (LoggingT m) where- absDirUrl = lift . absDirUrl- absFileUrl = lift . absFileUrl- locUrl = lift . locUrl+ ) => MonadUrl (LoggingT m) base where+ locToUrl = lift . locToUrl -instance ( MonadUrl m+instance ( MonadUrl m base , Monad m- ) => MonadUrl (NoLoggingT m) where- absDirUrl = lift . absDirUrl- absFileUrl = lift . absFileUrl- locUrl = lift . locUrl+ ) => MonadUrl (NoLoggingT m) base where+ locToUrl = lift . locToUrl -instance ( MonadUrl m+instance ( MonadUrl m base , Monad m- ) => MonadUrl (ReaderT r m) where- absDirUrl = lift . absDirUrl- absFileUrl = lift . absFileUrl- locUrl = lift . locUrl+ ) => MonadUrl (ReaderT r m) base where+ locToUrl = lift . locToUrl -instance ( MonadUrl m+instance ( MonadUrl m base , Monad m , Monoid w- ) => MonadUrl (WriterT w m) where- absDirUrl = lift . absDirUrl- absFileUrl = lift . absFileUrl- locUrl = lift . locUrl+ ) => MonadUrl (WriterT w m) base where+ locToUrl = lift . locToUrl -instance ( MonadUrl m+instance ( MonadUrl m base , Monad m- ) => MonadUrl (StateT s m) where- absDirUrl = lift . absDirUrl- absFileUrl = lift . absFileUrl- locUrl = lift . locUrl+ ) => MonadUrl (StateT s m) base where+ locToUrl = lift . locToUrl -instance ( MonadUrl m+instance ( MonadUrl m base , Monad m , Error e- ) => MonadUrl (ErrorT e m) where- absDirUrl = lift . absDirUrl- absFileUrl = lift . absFileUrl- locUrl = lift . locUrl+ ) => MonadUrl (ErrorT e m) base where+ locToUrl = lift . locToUrl -instance ( MonadUrl m+instance ( MonadUrl m base , Monad m- ) => MonadUrl (ContT r m) where- absDirUrl = lift . absDirUrl- absFileUrl = lift . absFileUrl- locUrl = lift . locUrl+ ) => MonadUrl (ContT r m) base where+ locToUrl = lift . locToUrl -instance ( MonadUrl m+instance ( MonadUrl m base , Monad m- ) => MonadUrl (ExceptT e m) where- absDirUrl = lift . absDirUrl- absFileUrl = lift . absFileUrl- locUrl = lift . locUrl+ ) => MonadUrl (ExceptT e m) base where+ locToUrl = lift . locToUrl -instance ( MonadUrl m+instance ( MonadUrl m base , Monad m , Monoid w- ) => MonadUrl (RWST r w s m) where- absDirUrl = lift . absDirUrl- absFileUrl = lift . absFileUrl- locUrl = lift . locUrl+ ) => MonadUrl (RWST r w s m) base where+ locToUrl = lift . locToUrl -- * Types +-- ** URL +-- | Either a URI (which could include a hostname), or a relative url.+data URL = AbsURL URI | RelURL (Location Rel)++printURL :: URL -> T.Text+printURL x = case x of+ AbsURL y -> printURI y+ RelURL y -> printLocation y++ -- ** Relative Urls +-- | When printing a 'URL' generated by a 'Location' in this context,+-- they will always omit the hostname information and print path references relatively+-- (without @./@). newtype RelativeUrlT m a = RelativeUrlT { runRelativeUrlT :: m a } deriving ( Show, Eq, Ord, Functor, Applicative, Alternative, Monad, MonadFix@@ -234,14 +241,14 @@ instance ( Applicative m- ) => MonadUrl (RelativeUrlT m) where- absDirUrl = pure . mkUriLocEmpty . fromAbsDir- absFileUrl = pure . mkUriLocEmpty . fromAbsFile- locUrl = pure . mkUriLocEmpty+ ) => MonadUrl (RelativeUrlT m) Rel where+ locToUrl = pure . RelURL -- ** Grounded Urls +-- | "Grounded" urls mean that, while omiting host information, paths start with+-- a @/@, like @/foo@. newtype GroundedUrlT m a = GroundedUrlT { runGroundedUrlT :: m a } deriving ( Show, Eq, Ord, Functor, Applicative, Alternative, Monad, MonadFix@@ -283,25 +290,23 @@ embed f x = f (runGroundedUrlT x) instance ( Applicative m- ) => MonadUrl (GroundedUrlT m) where- absDirUrl = pure . mkUriLocEmpty . fromAbsDir- absFileUrl = pure . mkUriLocEmpty . fromAbsFile- locUrl = pure . mkUriLocEmpty+ ) => MonadUrl (GroundedUrlT m) Abs where+ locToUrl = pure . AbsURL . mkUriLocEmpty -- ** Absolute Urls +-- | Given a means to take an absolute location and turn it into an URI, make a monad used to+-- construct urls. You can use 'packLocation' to create the @Location Abs -> URI@ function. newtype AbsoluteUrlT m a = AbsoluteUrlT- { runAbsoluteUrlT :: (Location -> URI) -> m a+ { runAbsoluteUrlT :: (Location Abs -> URI) -> m a } deriving Functor type AbsoluteUrl = AbsoluteUrlT Identity instance ( Applicative m- ) => MonadUrl (AbsoluteUrlT m) where- locUrl x = AbsoluteUrlT (\f -> pure (f x))- absDirUrl x = AbsoluteUrlT (\f -> pure (f (fromAbsDir x)))- absFileUrl x = AbsoluteUrlT (\f -> pure (f (fromAbsFile x)))+ ) => MonadUrl (AbsoluteUrlT m) Abs where+ locToUrl x = AbsoluteUrlT (\f -> pure . AbsURL $ f x) instance Applicative m => Applicative (AbsoluteUrlT m) where pure x = AbsoluteUrlT $ const (pure x)@@ -313,7 +318,6 @@ (AbsoluteUrlT f) <|> (AbsoluteUrlT g) = AbsoluteUrlT $ \h -> f h <|> g h 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) @@ -422,45 +426,58 @@ runAbsoluteUrlT (f (runAbsoluteUrlT x r)) r -mkUriLocEmpty :: Location -> URI-mkUriLocEmpty = packLocation Strict.Nothing False (URIAuth Strict.Nothing Localhost Strict.Nothing)+mkUriLocEmpty :: Location Abs -> URI+mkUriLocEmpty =+ packLocation Strict.Nothing False (URIAuth Strict.Nothing Strict.Nothing Localhost Strict.Nothing) getPathChunks :: Path base type' -> V.Vector T.Text-getPathChunks path = V.fromList $ fmap T.pack $ splitOn "/" $ dropWhile (== '/') (toFilePath path)+getPathChunks = V.fromList . fmap T.pack . splitOn "/" . dropWhile (== '/') . toFilePath -packLocation :: Strict.Maybe T.Text -> Bool -> URIAuth -> Location -> URI-packLocation scheme slashes auth loc =+packLocation :: Strict.Maybe T.Text -> Bool -> URIAuth -> Location Abs -> URI+packLocation scheme slashes auth Location{..} = URI scheme slashes auth- (Strict.Just $ either getPathChunks getPathChunks (locPath loc)+ (Strict.Just $ case locPath of+ Path.Dir xs -> (getPathChunks xs, URI.Dir)+ Path.File xs -> (getPathChunks xs, URI.File) ) (V.fromList $ map (\(l,r) -> T.pack l Strict.:!: maybe Strict.Nothing (Strict.Just . T.pack) r)- $ getQuery loc+ locQueryParams )- (maybe Strict.Nothing (Strict.Just . T.pack) (getFragment loc))+ (maybe Strict.Nothing (Strict.Just . T.pack) locFragment) -unpackLocation :: URI -> (Strict.Maybe T.Text, Bool, URIAuth, Location)+unpackLocation :: URI -> (Strict.Maybe T.Text, Bool, URIAuth, Location Abs) unpackLocation (URI scheme slashes auth xs qs mFrag) = ( scheme , slashes , auth- , let path :: Either (Path Abs Dir) (Path Abs File)+ , let path :: LocationPath Abs path = case xs of- Strict.Nothing -> Left [absdir|/|]- Strict.Just xs'- | xs' == [] -> Left [absdir|/|]- | otherwise -> Right $- foldl (\acc x -> unsafeCoerce acc </> unsafePerformIO (parseRelFile $ T.unpack x))- (unsafePerformIO $ unsafeCoerce <$> parseAbsDir "/")- xs'- withQs :: Location- withQs = foldl (\acc (k Strict.:!: mV) -> acc <&> (T.unpack k, Strict.maybe Nothing (Just . T.unpack) mV))- (either fromAbsDir fromAbsFile path)- qs+ Strict.Nothing -> Path.Dir [absdir|/|]+ Strict.Just (xs', dirOrFile)+ | xs' == [] -> Path.Dir [absdir|/|]+ | otherwise ->+ case dirOrFile of+ URI.File -> Path.File $+ foldl (\acc x -> unsafeCoerce acc </> unsafePerformIO (parseRelFile $ T.unpack x))+ (unsafePerformIO $ unsafeCoerce <$> parseAbsDir "/")+ xs'+ URI.Dir -> Path.Dir $+ foldl (\acc x -> unsafeCoerce acc </> unsafePerformIO (parseRelDir $ T.unpack x <> "/"))+ (unsafePerformIO $ unsafeCoerce <$> parseAbsDir "/")+ xs'+ withQs :: Location Abs+ withQs =+ foldl+ (\acc (k Strict.:!: mV) ->+ acc <&> (T.unpack k, Strict.maybe Nothing (Just . T.unpack) mV)+ )+ (Location path [] Nothing)+ qs in setFragment (Strict.maybe Nothing (Just . T.unpack) mFrag) withQs )
urlpath.cabal view
@@ -1,24 +1,24 @@--- This file has been generated from package.yaml by hpack version 0.21.2.+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack ----- hash: 6cefde9c8088edade18012c83ffd8595977d63e1efdedd57b09a1cebf14ca5bf+-- hash: 48c44feca6dd19038002a3f84713aa9db6c50044e70af8591d3de84255dc3e83 name: urlpath-version: 9.0.1+version: 10.0.0 synopsis: Painfully simple URL deployment.-description: Please see the README on Github at <https://github.com/githubuser/urlpath#readme>+description: Please see the README on Github at <https://github.com/athanclark/urlpath#readme> category: Web, Data homepage: https://github.com/athanclark/urlpath#readme bug-reports: https://github.com/athanclark/urlpath/issues author: Athan Clark-maintainer: athan.clark@localcooking.com-copyright: Copyright (c) 2018 Athan Clark+maintainer: athan.clark@gmail.com+copyright: Copyright (c) 2023 Athan Clark license: BSD3 license-file: LICENSE build-type: Simple-cabal-version: >= 1.10- extra-source-files: README.md @@ -35,16 +35,16 @@ src ghc-options: -Wall build-depends:- attoparsec-uri >=0.0.6+ attoparsec-uri >=0.0.9 , base >=4.11 && <5 , exceptions , mmorph , monad-control- , monad-control-aligned+ , monad-control-aligned >=0.0.2 , monad-logger , mtl- , path- , path-extra >=0.2.0+ , path >=0.9+ , path-extra >=0.3.0 , resourcet , split , strict