diff --git a/src/Data/Url.hs b/src/Data/Url.hs --- a/src/Data/Url.hs +++ b/src/Data/Url.hs @@ -2,12 +2,12 @@ TypeFamilies , DeriveFunctor , KindSignatures + , OverloadedStrings , FlexibleInstances , StandaloneDeriving , TypeSynonymInstances , UndecidableInstances , MultiParamTypeClasses - , FunctionalDependencies , GeneralizedNewtypeDeriving #-} @@ -34,11 +34,19 @@ import Path.Extended import Data.Functor.Identity +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 import Control.Monad.Base import Control.Monad.Catch import Control.Monad.Cont -import Control.Monad.Error +import Control.Monad.Trans.Error (Error, ErrorT) import Control.Monad.Except import Control.Monad.Trans.Control import Control.Monad.Trans.Identity @@ -61,13 +69,13 @@ -- @LoggingT@ and @NoLoggingT@ from . class MonadUrl base type' (m :: * -> *) where pathUrl :: Path base type' - -> m String + -> m URI locUrl :: Location base type' - -> m String + -> m URI instance MonadUrl b t IO where - pathUrl = pure . toFilePath - locUrl = pure . show + pathUrl x = pure (mkUriPathEmpty x) + locUrl x = pure (mkUriLocEmpty x) instance ( MonadUrl b t m , Monad m @@ -153,33 +161,7 @@ -- * Types --- | The hostname of a URL. -data UrlAuthority = UrlAuthority - { urlScheme :: String - , urlSlashes :: Bool - , urlAuth :: Maybe UrlAuthent - , urlHost :: String - , urlPort :: Maybe Int - } deriving (Show, Eq, Ord) -showUrlAuthority :: UrlAuthority -> String -showUrlAuthority (UrlAuthority sh sl ma h mp) = - sh ++ ":" - ++ (if sl then "//" else "") - ++ maybe "" (\a -> showUrlAuthent a ++ "@") ma - ++ h - ++ maybe "" (\p -> ":" ++ show p) mp - -data UrlAuthent = UrlAuthent - { urlAuthUser :: String - , urlAuthPass :: Maybe String - } deriving (Show, Eq, Ord) - -showUrlAuthent :: UrlAuthent -> String -showUrlAuthent (UrlAuthent u mp) = - u ++ maybe "" (\p -> ":" ++ p) mp - - -- ** Relative Urls newtype RelativeUrlT m a = RelativeUrlT @@ -198,7 +180,7 @@ instance MonadTransControl RelativeUrlT where type StT RelativeUrlT a = a - liftWith f = RelativeUrlT (f (\t -> runRelativeUrlT t)) + liftWith f = RelativeUrlT (f runRelativeUrlT) restoreT = RelativeUrlT instance ( MonadBaseControl b m @@ -216,13 +198,13 @@ instance ( Applicative m ) => MonadUrl Rel File (RelativeUrlT m) where - pathUrl x = pure (toFilePath x) - locUrl x = pure (show x) + pathUrl x = pure (mkUriPathEmpty x) + locUrl x = pure (mkUriLocEmpty x) instance ( Applicative m ) => MonadUrl Rel Dir (RelativeUrlT m) where - pathUrl x = pure (toFilePath x) - locUrl x = pure (show x) + pathUrl x = pure (mkUriPathEmpty x) + locUrl x = pure (mkUriLocEmpty x) -- ** Grounded Urls @@ -243,7 +225,7 @@ instance MonadTransControl GroundedUrlT where type StT GroundedUrlT a = a - liftWith f = GroundedUrlT (f (\t -> runGroundedUrlT t)) + liftWith f = GroundedUrlT (f runGroundedUrlT) restoreT = GroundedUrlT instance ( MonadBaseControl b m @@ -260,32 +242,32 @@ instance ( Applicative m ) => MonadUrl Abs File (GroundedUrlT m) where - pathUrl x = pure (toFilePath x) - locUrl x = pure (show x) + pathUrl x = pure (mkUriPathEmpty x) + locUrl x = pure (mkUriLocEmpty x) instance ( Applicative m ) => MonadUrl Abs Dir (GroundedUrlT m) where - pathUrl x = pure (toFilePath x) - locUrl x = pure (show x) + pathUrl x = pure (mkUriPathEmpty x) + locUrl x = pure (mkUriLocEmpty x) -- ** Absolute Urls newtype AbsoluteUrlT m a = AbsoluteUrlT - { runAbsoluteUrlT :: UrlAuthority -> m a + { runAbsoluteUrlT :: URIAuth -> m a } deriving Functor type AbsoluteUrl = AbsoluteUrlT Identity instance ( Applicative m ) => MonadUrl Abs File (AbsoluteUrlT m) where - pathUrl x = AbsoluteUrlT (\h -> pure $ showUrlAuthority h ++ toFilePath x) - locUrl x = AbsoluteUrlT (\h -> pure $ showUrlAuthority h ++ show x) + pathUrl x = AbsoluteUrlT (\h -> pure $ mkUriPath h x) + locUrl x = AbsoluteUrlT (\h -> pure $ mkUriLoc h x) instance ( Applicative m ) => MonadUrl Abs Dir (AbsoluteUrlT m) where - pathUrl x = AbsoluteUrlT (\h -> pure $ showUrlAuthority h ++ toFilePath x) - locUrl x = AbsoluteUrlT (\h -> pure $ showUrlAuthority h ++ show x) + pathUrl x = AbsoluteUrlT (\h -> pure $ mkUriPath h x) + locUrl x = AbsoluteUrlT (\h -> pure $ mkUriLoc h x) instance Applicative m => Applicative (AbsoluteUrlT m) where pure x = AbsoluteUrlT $ const (pure x) @@ -293,7 +275,7 @@ runAbsoluteUrlT f r <*> runAbsoluteUrlT x r instance Alternative m => Alternative (AbsoluteUrlT m) where - empty = AbsoluteUrlT (\_ -> empty) + empty = AbsoluteUrlT (const empty) (AbsoluteUrlT f) <|> (AbsoluteUrlT g) = AbsoluteUrlT $ \h -> f h <|> g h instance Monad m => Monad (AbsoluteUrlT m) where @@ -389,3 +371,43 @@ instance MMonad AbsoluteUrlT where embed f x = AbsoluteUrlT $ \r -> runAbsoluteUrlT (f (runAbsoluteUrlT x r)) r + +mkUriPath :: URIAuth -> Path base type' -> URI +mkUriPath auth path = URI (Strict.Just "https") + True + auth + (V.fromList $ fmap T.pack $ splitOn "/" $ toFilePath path) + V.empty + Strict.Nothing + +mkUriPathEmpty :: Path base type' -> URI +mkUriPathEmpty path = URI Strict.Nothing + False + (URIAuth Strict.Nothing Localhost Strict.Nothing) + (V.fromList $ fmap T.pack $ splitOn "/" $ toFilePath path) + V.empty + Strict.Nothing + +mkUriLoc :: URIAuth -> Location base type' -> URI +mkUriLoc auth loc = URI (Strict.Just "https") + True + auth + (V.fromList $ fmap T.pack $ splitOn "/" $ toFilePath $ locPath loc) + ( V.fromList $ map (\(l,r) -> + (T.pack l) Strict.:!: + (maybe Strict.Nothing (Strict.Just . T.pack) r)) + (getQuery loc) + ) + (maybe Strict.Nothing (Strict.Just . T.pack) (getFragment loc)) + +mkUriLocEmpty :: Location base type' -> URI +mkUriLocEmpty loc = URI Strict.Nothing + False + (URIAuth Strict.Nothing Localhost Strict.Nothing) + (V.fromList $ fmap T.pack $ splitOn "/" $ toFilePath $ locPath loc) + ( V.fromList $ map (\(l,r) -> + (T.pack l) Strict.:!: + (maybe Strict.Nothing (Strict.Just . T.pack) r)) + (getQuery loc) + ) + (maybe Strict.Nothing (Strict.Just . T.pack) (getFragment loc)) diff --git a/urlpath.cabal b/urlpath.cabal --- a/urlpath.cabal +++ b/urlpath.cabal @@ -1,5 +1,5 @@ Name: urlpath -Version: 5.0.0.1 +Version: 6.0.0 Author: Athan Clark Maintainer: Athan Clark License: MIT @@ -17,15 +17,20 @@ GHC-Options: -Wall Exposed-Modules: Data.Url Build-Depends: base >= 4.8 && < 5 + , attoparsec-uri , exceptions , mmorph , monad-control , monad-logger , mtl - , path-extra >= 0.0.3 + , path-extra >= 0.0.5 , resourcet + , split + , strict + , text , transformers , transformers-base + , vector Source-Repository head Type: git