{-# 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 -> [Char]
showURI (URI {[Char]
Maybe URIAuth
uriScheme :: [Char]
uriAuthority :: Maybe URIAuth
uriPath :: [Char]
uriQuery :: [Char]
uriFragment :: [Char]
uriScheme :: URI -> [Char]
uriAuthority :: URI -> Maybe URIAuth
uriPath :: URI -> [Char]
uriQuery :: URI -> [Char]
uriFragment :: URI -> [Char]
..}) =
    [Char]
"URI {uriScheme = " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
uriScheme [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
       [Char]
", uriAuthority = " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Maybe URIAuth -> [Char]
forall a. Show a => a -> [Char]
show Maybe URIAuth
uriAuthority [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
       [Char]
", uriPath = " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
uriPath [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
       [Char]
", uriQuery = " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
uriQuery [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
       [Char]
", uriFragment = " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
uriFragment [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"}"

-- | parseURI with MonadError
parseURI' :: (HasURIError e, MonadError e m) => String -> m URI
parseURI' :: forall e (m :: * -> *).
(HasURIError e, MonadError e m) =>
[Char] -> m URI
parseURI' [Char]
s = m URI -> (URI -> m URI) -> Maybe URI -> m URI
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> m URI
forall a. e -> m a
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
$ [Char] -> [Char] -> URIError
URIParseError [Char]
"parseURI" [Char]
s) URI -> m URI
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Maybe URI
parseURI [Char]
s)
parseURIReference' :: (HasURIError e, MonadError e m) => String -> m URI
parseURIReference' :: forall e (m :: * -> *).
(HasURIError e, MonadError e m) =>
[Char] -> m URI
parseURIReference' [Char]
s = m URI -> (URI -> m URI) -> Maybe URI -> m URI
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> m URI
forall a. e -> m a
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
$ [Char] -> [Char] -> URIError
URIParseError [Char]
"parseURIReference" [Char]
s) URI -> m URI
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Maybe URI
parseURIReference [Char]
s)
parseAbsoluteURI' :: (HasURIError e, MonadError e m) => String -> m URI
parseAbsoluteURI' :: forall e (m :: * -> *).
(HasURIError e, MonadError e m) =>
[Char] -> m URI
parseAbsoluteURI' [Char]
s = m URI -> (URI -> m URI) -> Maybe URI -> m URI
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> m URI
forall a. e -> m a
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
$ [Char] -> [Char] -> URIError
URIParseError [Char]
"parseAbsoluteURI" [Char]
s) URI -> m URI
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Maybe URI
parseAbsoluteURI [Char]
s)
parseRelativeReference' :: (HasURIError e, MonadError e m) => String -> m URI
parseRelativeReference' :: forall e (m :: * -> *).
(HasURIError e, MonadError e m) =>
[Char] -> m URI
parseRelativeReference' [Char]
s = m URI -> (URI -> m URI) -> Maybe URI -> m URI
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> m URI
forall a. e -> m a
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
$ [Char] -> [Char] -> URIError
URIParseError [Char]
"parseRelativeReference" [Char]
s) URI -> m URI
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Maybe URI
parseRelativeReference [Char]
s)

parseURIUnsafe :: String -> URI
parseURIUnsafe :: [Char] -> URI
parseURIUnsafe [Char]
s = URI -> Maybe URI -> URI
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> URI
forall a. HasCallStack => [Char] -> a
error ([Char]
"parseURIUnsafe " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
s)) (Maybe URI -> URI) -> Maybe URI -> URI
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe URI
parseURIReference [Char]
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
$c== :: URIError -> URIError -> Bool
== :: URIError -> URIError -> Bool
$c/= :: URIError -> URIError -> Bool
/= :: 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
$ccompare :: URIError -> URIError -> Ordering
compare :: URIError -> URIError -> Ordering
$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
>= :: URIError -> URIError -> Bool
$cmax :: URIError -> URIError -> URIError
max :: URIError -> URIError -> URIError
$cmin :: URIError -> URIError -> URIError
min :: URIError -> URIError -> URIError
Ord, Int -> URIError -> [Char] -> [Char]
[URIError] -> [Char] -> [Char]
URIError -> [Char]
(Int -> URIError -> [Char] -> [Char])
-> (URIError -> [Char])
-> ([URIError] -> [Char] -> [Char])
-> Show URIError
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> URIError -> [Char] -> [Char]
showsPrec :: Int -> URIError -> [Char] -> [Char]
$cshow :: URIError -> [Char]
show :: URIError -> [Char]
$cshowList :: [URIError] -> [Char] -> [Char]
showList :: [URIError] -> [Char] -> [Char]
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 :: forall (m :: * -> *). MonadError URIError m => URI -> URI -> m URI
appendURI (URI [Char]
scheme Maybe URIAuth
auth [Char]
path1 [Char]
"" [Char]
"") (URI [Char]
"" Maybe URIAuth
Nothing [Char]
path2 [Char]
query [Char]
fragment) = URI -> m URI
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (URI -> m URI) -> URI -> m URI
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe URIAuth -> [Char] -> [Char] -> [Char] -> URI
URI [Char]
scheme Maybe URIAuth
auth ([Char]
path1 [Char] -> [Char] -> [Char]
</> [Char]
path2) [Char]
query [Char]
fragment
    -- Use query from RHS
appendURI URI
a URI
b = URIError -> m URI
forall a. URIError -> m a
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 :: forall (t :: * -> *) (m :: * -> *).
(Foldable t, MonadError URIError m) =>
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 = takeDirectory (dropTrailingPathSeparator (uriPath 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 = [Char] -> Maybe URI
parseURIReference (URI -> [Char]
forall a. Show a => a -> [Char]
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
$creadsPrec :: Int -> ReadS URI'
readsPrec :: Int -> ReadS URI'
$creadList :: ReadS [URI']
readList :: ReadS [URI']
$creadPrec :: ReadPrec URI'
readPrec :: ReadPrec URI'
$creadListPrec :: ReadPrec [URI']
readListPrec :: ReadPrec [URI']
Read, Int -> URI' -> [Char] -> [Char]
[URI'] -> [Char] -> [Char]
URI' -> [Char]
(Int -> URI' -> [Char] -> [Char])
-> (URI' -> [Char]) -> ([URI'] -> [Char] -> [Char]) -> Show URI'
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> URI' -> [Char] -> [Char]
showsPrec :: Int -> URI' -> [Char] -> [Char]
$cshow :: URI' -> [Char]
show :: URI' -> [Char]
$cshowList :: [URI'] -> [Char] -> [Char]
showList :: [URI'] -> [Char] -> [Char]
Show, URI' -> URI' -> Bool
(URI' -> URI' -> Bool) -> (URI' -> URI' -> Bool) -> Eq URI'
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: URI' -> URI' -> Bool
== :: URI' -> URI' -> Bool
$c/= :: URI' -> URI' -> Bool
/= :: 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
$ccompare :: URI' -> URI' -> Ordering
compare :: URI' -> URI' -> Ordering
$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
>= :: URI' -> URI' -> Bool
$cmax :: URI' -> URI' -> URI'
max :: URI' -> URI' -> URI'
$cmin :: URI' -> URI' -> URI'
min :: URI' -> URI' -> URI'
Ord)

readURI' :: String -> Maybe URI'
readURI' :: [Char] -> Maybe URI'
readURI' [Char]
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 ([Char] -> URI'
URI' [Char]
s))) ([Char] -> Maybe URI
parseURIReference [Char]
s)

fromURI' :: URI' -> URI
fromURI' :: URI' -> URI
fromURI' (URI' [Char]
s) = Maybe URI -> URI
forall a. HasCallStack => Maybe a -> a
fromJust ([Char] -> Maybe URI
parseURI [Char]
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' = [Char] -> URI'
URI' ([Char] -> URI') -> (URI -> [Char]) -> URI -> URI'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> [Char]
forall a. Show a => a -> [Char]
show

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

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 = [Char] -> [Char] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (ParseError -> [Char]
forall a. Show a => a -> [Char]
show ParseError
a) (ParseError -> [Char]
forall a. Show a => a -> [Char]
show ParseError
b)