diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -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"
-
-↪ ""
-```
-
-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.)
diff --git a/src/Data/Url.hs b/src/Data/Url.hs
--- a/src/Data/Url.hs
+++ b/src/Data/Url.hs
@@ -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 .
-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
)
diff --git a/urlpath.cabal b/urlpath.cabal
--- a/urlpath.cabal
+++ b/urlpath.cabal
@@ -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
+description: Please see the README on Github at
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