{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE DeriveGeneric          #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiWayIf             #-}
{-# LANGUAGE OverloadedStrings      #-}
{-# LANGUAGE TypeApplications       #-}
{-# LANGUAGE TypeFamilies           #-}

module HaskellWorks.CabalCache.Location
( IsPath(..)
, Location(..)
, toLocation
)
where

import Antiope.Core                 (ToText (..))
import Antiope.S3                   (ObjectKey (..), S3Uri (..))
import Control.Lens                 hiding ((<.>))
import Data.Generics.Product.Any
import Data.Maybe                   (fromMaybe)
import Data.Text                    (Text)
import GHC.Generics                 (Generic)
import HaskellWorks.CabalCache.Show
import Network.URI                  (URI)

import qualified Data.Text       as T
import qualified Network.URI     as URI
import qualified System.FilePath as FP

class IsPath a s | a -> s where
  (</>) :: a -> s -> a
  (<.>) :: a -> s -> a

infixr 5 </>
infixr 7 <.>

data Location
  = Uri URI
  | Local FilePath
  deriving (Int -> Location -> ShowS
[Location] -> ShowS
Location -> String
(Int -> Location -> ShowS)
-> (Location -> String) -> ([Location] -> ShowS) -> Show Location
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Location] -> ShowS
$cshowList :: [Location] -> ShowS
show :: Location -> String
$cshow :: Location -> String
showsPrec :: Int -> Location -> ShowS
$cshowsPrec :: Int -> Location -> ShowS
Show, Location -> Location -> Bool
(Location -> Location -> Bool)
-> (Location -> Location -> Bool) -> Eq Location
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Location -> Location -> Bool
$c/= :: Location -> Location -> Bool
== :: Location -> Location -> Bool
$c== :: Location -> Location -> Bool
Eq, (forall x. Location -> Rep Location x)
-> (forall x. Rep Location x -> Location) -> Generic Location
forall x. Rep Location x -> Location
forall x. Location -> Rep Location x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Location x -> Location
$cfrom :: forall x. Location -> Rep Location x
Generic)

instance ToText Location where
  toText :: Location -> Text
toText (Uri URI
uri) = URI -> Text
forall a. Show a => a -> Text
tshow URI
uri
  toText (Local String
p) = String -> Text
T.pack String
p

instance IsPath Location Text where
  Uri   URI
b </> :: Location -> Text -> Location
</> Text
p = URI -> Location
Uri   (URI
b URI -> Text -> URI
forall a s. IsPath a s => a -> s -> a
</> Text
p)
  Local String
b </> Text
p = String -> Location
Local (String
b String -> ShowS
forall a s. IsPath a s => a -> s -> a
</> Text -> String
T.unpack Text
p)

  Uri   URI
b <.> :: Location -> Text -> Location
<.> Text
e = URI -> Location
Uri   (URI
b URI -> Text -> URI
forall a s. IsPath a s => a -> s -> a
<.> Text
e)
  Local String
b <.> Text
e = String -> Location
Local (String
b String -> ShowS
forall a s. IsPath a s => a -> s -> a
<.> Text -> String
T.unpack Text
e)

instance IsPath Text Text where
  Text
b </> :: Text -> Text -> Text
</> Text
p = String -> Text
T.pack (Text -> String
T.unpack Text
b String -> ShowS
FP.</> Text -> String
T.unpack Text
p)
  Text
b <.> :: Text -> Text -> Text
<.> Text
e = String -> Text
T.pack (Text -> String
T.unpack Text
b String -> ShowS
FP.<.> Text -> String
T.unpack Text
e)

instance IsPath URI Text where
  URI
b </> :: URI -> Text -> URI
</> Text
p = URI
b URI -> (URI -> URI) -> URI
forall a b. a -> (a -> b) -> b
& forall k (sel :: k) s t a b. HasAny sel s t a b => Lens s t a b
forall s t a b. HasAny "uriPath" s t a b => Lens s t a b
the @"uriPath" ((String -> Identity String) -> URI -> Identity URI)
-> ShowS -> URI -> URI
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
p)
  URI
b <.> :: URI -> Text -> URI
<.> Text
e = URI
b URI -> (URI -> URI) -> URI
forall a b. a -> (a -> b) -> b
& forall k (sel :: k) s t a b. HasAny sel s t a b => Lens s t a b
forall s t a b. HasAny "uriPath" s t a b => Lens s t a b
the @"uriPath" ((String -> Identity String) -> URI -> Identity URI)
-> ShowS -> URI -> URI
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"." String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
e)

instance (a ~ Char) => IsPath [a] [a] where
  [a]
b </> :: [a] -> [a] -> [a]
</> [a]
p = [a]
String
b String -> ShowS
FP.</> [a]
String
p
  [a]
b <.> :: [a] -> [a] -> [a]
<.> [a]
e = [a]
String
b String -> ShowS
FP.<.> [a]
String
e

instance IsPath S3Uri Text where
  S3Uri BucketName
b (ObjectKey Text
k) </> :: S3Uri -> Text -> S3Uri
</> Text
p =
    BucketName -> ObjectKey -> S3Uri
S3Uri BucketName
b (Text -> ObjectKey
ObjectKey (Text -> Text -> Text
stripEnd Text
"/" Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
stripStart Text
"/" Text
p))

  S3Uri BucketName
b (ObjectKey Text
k) <.> :: S3Uri -> Text -> S3Uri
<.> Text
e =
    BucketName -> ObjectKey -> S3Uri
S3Uri BucketName
b (Text -> ObjectKey
ObjectKey (Text -> Text -> Text
stripEnd Text
"." Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
stripStart Text
"." Text
e))

toLocation :: Text -> Maybe Location
toLocation :: Text -> Maybe Location
toLocation Text
t = case String -> Maybe URI
URI.parseURI (Text -> String
T.unpack Text
t) of
  Just URI
uri -> Location -> Maybe Location
forall a. a -> Maybe a
Just (URI -> Location
Uri URI
uri)
  Maybe URI
Nothing  -> Location -> Maybe Location
forall a. a -> Maybe a
Just (String -> Location
Local (Text -> String
T.unpack Text
t))

-------------------------------------------------------------------------------
stripStart :: Text -> Text -> Text
stripStart :: Text -> Text -> Text
stripStart Text
what Text
txt = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
txt (Text -> Text -> Maybe Text
T.stripPrefix Text
what Text
txt)

stripEnd :: Text -> Text -> Text
stripEnd :: Text -> Text -> Text
stripEnd Text
what Text
txt = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
txt (Text -> Text -> Maybe Text
T.stripSuffix Text
what Text
txt)