{-# LANGUAGE CPP, DeriveDataTypeable, OverloadedStrings, PackageImports, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS -Wall -fno-warn-orphans #-}

module Debian.URI
    ( module Network.URI

#if 0
    , _NodeElement -- :: Prism' Node Element
    , _NodeContent -- :: Prism' Node Text
    , eltAttrsLens -- :: Lens' Element (HashMap AttrName AttrValue)
    , eltChildrenLens --  :: Lens' Element [Node]
    , eltNameLens -- :: Lens' Element Text
#endif

    , URIError(..)
    , uriSchemeLens
    , uriAuthorityLens
    , uriPathLens
    , uriQueryLens
    , uriFragmentLens
    -- * String known to parsable by parseURIReference.  Mainly
    -- useful because it has a Read instance.
    , URI'(..)
    , fromURI'
    , toURI'
    , readURI'

    -- Show URI as a Haskell expression
    , showURI
    -- Monadic URI parsers
    , parseURIReference'
    , parseURI'
    , parseAbsoluteURI'
    , parseRelativeReference'
    , parseURIUnsafe
    -- URI appending
    , appendURI
    , appendURIs
    , parentURI
    , uriToString'
    -- * Lift IO operations into a MonadError instance
    , HasParseError(fromParseError)
    , HasURIError(fromURIError)
    -- * QuickCheck properties
    , prop_print_parse
    , prop_append_singleton
    ) where

import Control.Lens (makeLensesFor)
import Control.Monad.Except (MonadError, throwError)
import Data.Foldable (foldrM)
import Data.Maybe (fromJust, fromMaybe)
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import Network.URI (nullURI, parseURIReference, parseURI, parseAbsoluteURI, parseRelativeReference, URI(..), URIAuth(..), uriToString)
import System.FilePath ((</>), dropTrailingPathSeparator, takeDirectory)
import Text.Parsec (ParseError)

$(makeLensesFor [("uriScheme", "uriSchemeLens"),
                 ("uriAuthority", "uriAuthorityLens"),
                 ("uriPath", "uriPathLens"),
                 ("uriQuery", "uriQueryLens"),
                 ("uriFragment", "uriFragmentLens")] ''URI)

showURI :: URI -> String
showURI :: URI -> String
showURI (URI {String
Maybe URIAuth
uriScheme :: URI -> String
uriAuthority :: URI -> Maybe URIAuth
uriPath :: URI -> String
uriQuery :: URI -> String
uriFragment :: URI -> String
uriFragment :: String
uriQuery :: String
uriPath :: String
uriAuthority :: Maybe URIAuth
uriScheme :: String
..}) =
    String
"URI {uriScheme = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
uriScheme String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
       String
", uriAuthority = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe URIAuth -> String
forall a. Show a => a -> String
show Maybe URIAuth
uriAuthority String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
       String
", uriPath = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
uriPath String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
       String
", uriQuery = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
uriQuery String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
       String
", uriFragment = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
uriFragment String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"}"

-- | parseURI with MonadError
parseURI' :: (HasURIError e, MonadError e m) => String -> m URI
parseURI' :: String -> m URI
parseURI' String
s = m URI -> (URI -> m URI) -> Maybe URI -> m URI
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> m URI
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e -> m URI) -> e -> m URI
forall a b. (a -> b) -> a -> b
$ URIError -> e
forall e. HasURIError e => URIError -> e
fromURIError (URIError -> e) -> URIError -> e
forall a b. (a -> b) -> a -> b
$ String -> String -> URIError
URIParseError String
"parseURI" String
s) URI -> m URI
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe URI
parseURI String
s)
parseURIReference' :: (HasURIError e, MonadError e m) => String -> m URI
parseURIReference' :: String -> m URI
parseURIReference' String
s = m URI -> (URI -> m URI) -> Maybe URI -> m URI
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> m URI
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e -> m URI) -> e -> m URI
forall a b. (a -> b) -> a -> b
$ URIError -> e
forall e. HasURIError e => URIError -> e
fromURIError (URIError -> e) -> URIError -> e
forall a b. (a -> b) -> a -> b
$ String -> String -> URIError
URIParseError String
"parseURIReference" String
s) URI -> m URI
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe URI
parseURIReference String
s)
parseAbsoluteURI' :: (HasURIError e, MonadError e m) => String -> m URI
parseAbsoluteURI' :: String -> m URI
parseAbsoluteURI' String
s = m URI -> (URI -> m URI) -> Maybe URI -> m URI
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> m URI
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e -> m URI) -> e -> m URI
forall a b. (a -> b) -> a -> b
$ URIError -> e
forall e. HasURIError e => URIError -> e
fromURIError (URIError -> e) -> URIError -> e
forall a b. (a -> b) -> a -> b
$ String -> String -> URIError
URIParseError String
"parseAbsoluteURI" String
s) URI -> m URI
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe URI
parseAbsoluteURI String
s)
parseRelativeReference' :: (HasURIError e, MonadError e m) => String -> m URI
parseRelativeReference' :: String -> m URI
parseRelativeReference' String
s = m URI -> (URI -> m URI) -> Maybe URI -> m URI
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> m URI
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e -> m URI) -> e -> m URI
forall a b. (a -> b) -> a -> b
$ URIError -> e
forall e. HasURIError e => URIError -> e
fromURIError (URIError -> e) -> URIError -> e
forall a b. (a -> b) -> a -> b
$ String -> String -> URIError
URIParseError String
"parseRelativeReference" String
s) URI -> m URI
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe URI
parseRelativeReference String
s)

parseURIUnsafe :: String -> URI
parseURIUnsafe :: String -> URI
parseURIUnsafe String
s = URI -> Maybe URI -> URI
forall a. a -> Maybe a -> a
fromMaybe (String -> URI
forall a. HasCallStack => String -> a
error (String
"parseURIUnsafe " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s)) (Maybe URI -> URI) -> Maybe URI -> URI
forall a b. (a -> b) -> a -> b
$ String -> Maybe URI
parseURIReference String
s

--parseAbsoluteURI :: String -> Maybe URI
--parseRelativeReference :: String -> Maybe URI
--parseURI :: String -> Maybe URI
--parseURIReference :: String -> Maybe URI

data URIError =
    URIParseError String String
  | URIAppendError URI URI
  deriving (URIError -> URIError -> Bool
(URIError -> URIError -> Bool)
-> (URIError -> URIError -> Bool) -> Eq URIError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: URIError -> URIError -> Bool
$c/= :: URIError -> URIError -> Bool
== :: URIError -> URIError -> Bool
$c== :: URIError -> URIError -> Bool
Eq, Eq URIError
Eq URIError
-> (URIError -> URIError -> Ordering)
-> (URIError -> URIError -> Bool)
-> (URIError -> URIError -> Bool)
-> (URIError -> URIError -> Bool)
-> (URIError -> URIError -> Bool)
-> (URIError -> URIError -> URIError)
-> (URIError -> URIError -> URIError)
-> Ord URIError
URIError -> URIError -> Bool
URIError -> URIError -> Ordering
URIError -> URIError -> URIError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: URIError -> URIError -> URIError
$cmin :: URIError -> URIError -> URIError
max :: URIError -> URIError -> URIError
$cmax :: URIError -> URIError -> URIError
>= :: URIError -> URIError -> Bool
$c>= :: URIError -> URIError -> Bool
> :: URIError -> URIError -> Bool
$c> :: URIError -> URIError -> Bool
<= :: URIError -> URIError -> Bool
$c<= :: URIError -> URIError -> Bool
< :: URIError -> URIError -> Bool
$c< :: URIError -> URIError -> Bool
compare :: URIError -> URIError -> Ordering
$ccompare :: URIError -> URIError -> Ordering
$cp1Ord :: Eq URIError
Ord, Int -> URIError -> String -> String
[URIError] -> String -> String
URIError -> String
(Int -> URIError -> String -> String)
-> (URIError -> String)
-> ([URIError] -> String -> String)
-> Show URIError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [URIError] -> String -> String
$cshowList :: [URIError] -> String -> String
show :: URIError -> String
$cshow :: URIError -> String
showsPrec :: Int -> URIError -> String -> String
$cshowsPrec :: Int -> URIError -> String -> String
Show)

-- | Conservative appending of absolute and relative URIs.  There may
-- be other cases that can be implemented, lets see if they turn up.
appendURI :: MonadError URIError m => URI -> URI -> m URI
    -- Append the two paths
appendURI :: URI -> URI -> m URI
appendURI (URI String
scheme Maybe URIAuth
auth String
path1 String
"" String
"") (URI String
"" Maybe URIAuth
Nothing String
path2 String
query String
fragment) = URI -> m URI
forall (m :: * -> *) a. Monad m => a -> m a
return (URI -> m URI) -> URI -> m URI
forall a b. (a -> b) -> a -> b
$ String -> Maybe URIAuth -> String -> String -> String -> URI
URI String
scheme Maybe URIAuth
auth (String
path1 String -> String -> String
</> String
path2) String
query String
fragment
    -- Use query from RHS
appendURI URI
a URI
b = URIError -> m URI
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (URI -> URI -> URIError
URIAppendError URI
a URI
b)

-- | Append a list of URI
-- @@
-- λ> appendURIs (parseURI "http://host.com") (parseURIRelative "/bar")
appendURIs :: (Foldable t, MonadError URIError m) => t URI -> m URI
appendURIs :: t URI -> m URI
appendURIs t URI
uris = (URI -> URI -> m URI) -> URI -> t URI -> m URI
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM URI -> URI -> m URI
forall (m :: * -> *). MonadError URIError m => URI -> URI -> m URI
appendURI URI
nullURI t URI
uris

parentURI :: URI -> URI
parentURI :: URI -> URI
parentURI URI
uri = URI
uri {uriPath :: String
uriPath = String -> String
takeDirectory (String -> String
dropTrailingPathSeparator (URI -> String
uriPath URI
uri))}

-- properties
-- appendURIs [x] == x

prop_append_singleton :: URI -> Bool
prop_append_singleton :: URI -> Bool
prop_append_singleton URI
uri = [URI] -> Either URIError URI
forall (t :: * -> *) (m :: * -> *).
(Foldable t, MonadError URIError m) =>
t URI -> m URI
appendURIs [URI
uri] Either URIError URI -> Either URIError URI -> Bool
forall a. Eq a => a -> a -> Bool
== URI -> Either URIError URI
forall a b. b -> Either a b
Right URI
uri

prop_print_parse :: URI -> Bool
prop_print_parse :: URI -> Bool
prop_print_parse URI
uri = String -> Maybe URI
parseURIReference (URI -> String
forall a. Show a => a -> String
show URI
uri) Maybe URI -> Maybe URI -> Bool
forall a. Eq a => a -> a -> Bool
== URI -> Maybe URI
forall a. a -> Maybe a
Just URI
uri

-- | A wrapper around a String containing a known parsable URI.  Not
-- absolutely safe, because you could say read "URI' \"bogus string\""
-- :: URI'.  But enough to save me from myself.
newtype URI' = URI' String deriving (ReadPrec [URI']
ReadPrec URI'
Int -> ReadS URI'
ReadS [URI']
(Int -> ReadS URI')
-> ReadS [URI'] -> ReadPrec URI' -> ReadPrec [URI'] -> Read URI'
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [URI']
$creadListPrec :: ReadPrec [URI']
readPrec :: ReadPrec URI'
$creadPrec :: ReadPrec URI'
readList :: ReadS [URI']
$creadList :: ReadS [URI']
readsPrec :: Int -> ReadS URI'
$creadsPrec :: Int -> ReadS URI'
Read, Int -> URI' -> String -> String
[URI'] -> String -> String
URI' -> String
(Int -> URI' -> String -> String)
-> (URI' -> String) -> ([URI'] -> String -> String) -> Show URI'
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [URI'] -> String -> String
$cshowList :: [URI'] -> String -> String
show :: URI' -> String
$cshow :: URI' -> String
showsPrec :: Int -> URI' -> String -> String
$cshowsPrec :: Int -> URI' -> String -> String
Show, URI' -> URI' -> Bool
(URI' -> URI' -> Bool) -> (URI' -> URI' -> Bool) -> Eq URI'
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: URI' -> URI' -> Bool
$c/= :: URI' -> URI' -> Bool
== :: URI' -> URI' -> Bool
$c== :: URI' -> URI' -> Bool
Eq, Eq URI'
Eq URI'
-> (URI' -> URI' -> Ordering)
-> (URI' -> URI' -> Bool)
-> (URI' -> URI' -> Bool)
-> (URI' -> URI' -> Bool)
-> (URI' -> URI' -> Bool)
-> (URI' -> URI' -> URI')
-> (URI' -> URI' -> URI')
-> Ord URI'
URI' -> URI' -> Bool
URI' -> URI' -> Ordering
URI' -> URI' -> URI'
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: URI' -> URI' -> URI'
$cmin :: URI' -> URI' -> URI'
max :: URI' -> URI' -> URI'
$cmax :: URI' -> URI' -> URI'
>= :: URI' -> URI' -> Bool
$c>= :: URI' -> URI' -> Bool
> :: URI' -> URI' -> Bool
$c> :: URI' -> URI' -> Bool
<= :: URI' -> URI' -> Bool
$c<= :: URI' -> URI' -> Bool
< :: URI' -> URI' -> Bool
$c< :: URI' -> URI' -> Bool
compare :: URI' -> URI' -> Ordering
$ccompare :: URI' -> URI' -> Ordering
$cp1Ord :: Eq URI'
Ord)

readURI' :: String -> Maybe URI'
readURI' :: String -> Maybe URI'
readURI' String
s = Maybe URI' -> (URI -> Maybe URI') -> Maybe URI -> Maybe URI'
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe URI'
forall a. Maybe a
Nothing (Maybe URI' -> URI -> Maybe URI'
forall a b. a -> b -> a
const (URI' -> Maybe URI'
forall a. a -> Maybe a
Just (String -> URI'
URI' String
s))) (String -> Maybe URI
parseURIReference String
s)

fromURI' :: URI' -> URI
fromURI' :: URI' -> URI
fromURI' (URI' String
s) = Maybe URI -> URI
forall a. HasCallStack => Maybe a -> a
fromJust (String -> Maybe URI
parseURI String
s) -- this should provably parse

-- | Using the bogus Show instance of URI here.  If it ever gets fixed
-- this will stop working.  Worth noting that show will obscure any
-- password info embedded in the URI, so that's nice.
toURI' :: URI -> URI'
toURI' :: URI -> URI'
toURI' = String -> URI'
URI' (String -> URI') -> (URI -> String) -> URI -> URI'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> String
forall a. Show a => a -> String
show

uriToString' :: URI -> String
uriToString' :: URI -> String
uriToString' URI
uri = (String -> String) -> URI -> String -> String
uriToString String -> String
forall a. a -> a
id URI
uri String
""

class HasParseError e where fromParseError :: ParseError -> e
instance HasParseError ParseError where fromParseError :: ParseError -> ParseError
fromParseError = ParseError -> ParseError
forall a. a -> a
id

class HasURIError e where fromURIError :: URIError -> e
instance HasURIError URIError where fromURIError :: URIError -> URIError
fromURIError = URIError -> URIError
forall a. a -> a
id

instance Ord ParseError where
    compare :: ParseError -> ParseError -> Ordering
compare ParseError
a ParseError
b = String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (ParseError -> String
forall a. Show a => a -> String
show ParseError
a) (ParseError -> String
forall a. Show a => a -> String
show ParseError
b)