{-# LANGUAGE DeriveGeneric          #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiWayIf             #-}
{-# LANGUAGE OverloadedStrings      #-}
{-# LANGUAGE TypeFamilies           #-}
module HaskellWorks.CabalCache.Location
( IsPath(..)
, Location(..)
, toLocation
)
where

import Antiope.Core (ToText (..), fromText)
import Antiope.S3   (ObjectKey (..), S3Uri (..))
import Data.Maybe   (fromMaybe)
import Data.Text    (Text)
import GHC.Generics (Generic)

import qualified Data.Text       as T
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
  = S3 S3Uri
  | Local FilePath
  | HttpUri Text
  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 (S3 S3Uri
uri)       = S3Uri -> Text
forall a. ToText a => a -> Text
toText S3Uri
uri
  toText (Local String
p)      = String -> Text
T.pack String
p
  toText (HttpUri Text
uri)  = Text
uri

instance IsPath Location Text where
  (S3      S3Uri
b) </> :: Location -> Text -> Location
</> Text
p = S3Uri -> Location
S3      (S3Uri
b S3Uri -> Text -> S3Uri
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)
  (HttpUri Text
b) </> Text
p = Text -> Location
HttpUri (Text
b Text -> Text -> Text
forall a s. IsPath a s => a -> s -> a
</>          Text
p)

  (S3      S3Uri
b) <.> :: Location -> Text -> Location
<.> Text
e = S3Uri -> Location
S3      (S3Uri
b S3Uri -> Text -> S3Uri
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)
  (HttpUri Text
b) <.> Text
e = Text -> Location
HttpUri (Text
b Text -> Text -> Text
forall a s. IsPath a s => a -> s -> a
<.>          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 (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
txt = if
  | Text -> Text -> Bool
T.isPrefixOf Text
"s3://" Text
txt'    -> (String -> Maybe Location)
-> (S3Uri -> Maybe Location)
-> Either String S3Uri
-> Maybe Location
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Location -> String -> Maybe Location
forall a b. a -> b -> a
const Maybe Location
forall a. Maybe a
Nothing) (Location -> Maybe Location
forall a. a -> Maybe a
Just (Location -> Maybe Location)
-> (S3Uri -> Location) -> S3Uri -> Maybe Location
forall b c a. (b -> c) -> (a -> b) -> a -> c
. S3Uri -> Location
S3) (Text -> Either String S3Uri
forall a. FromText a => Text -> Either String a
fromText Text
txt')
  | Text -> Text -> Bool
T.isPrefixOf Text
"file://" Text
txt'  -> Location -> Maybe Location
forall a. a -> Maybe a
Just (String -> Location
Local (Text -> String
T.unpack Text
txt'))
  | Text -> Text -> Bool
T.isPrefixOf Text
"http://" Text
txt'  -> Location -> Maybe Location
forall a. a -> Maybe a
Just (Text -> Location
HttpUri Text
txt')
  | Text -> Text -> Bool
T.isInfixOf  Text
"://" Text
txt'      -> Maybe Location
forall a. Maybe a
Nothing
  | Bool
otherwise                       -> Location -> Maybe Location
forall a. a -> Maybe a
Just (String -> Location
Local (Text -> String
T.unpack Text
txt'))
  where txt' :: Text
txt' = Text -> Text
T.strip Text
txt

-------------------------------------------------------------------------------
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)