{-# LANGUAGE TemplateHaskell #-}

import qualified Aws                  as Aws
import qualified Aws.S3               as S3
import qualified Data.ByteString.Lazy as BL (hGetContents)
import           Data.Text                  (pack, unpack)
import           Control.Monad              (when)
import           Data.Conduit               (($$+-))
import           Data.Maybe                 (isJust, fromJust)
import           Data.Conduit.Binary        (sinkFile)
import           HFlags
import           Network.URI                (URI, uriScheme, uriAuthority, uriRegName, uriPath,
                                             parseURI, parseURIReference)
import           Network.HTTP.Conduit       (withManager, responseBody, RequestBody (..))
import qualified System.IO            as IO (withFile, IOMode (ReadMode))
import           System.Exit                (exitFailure)

newtype S3Path = S3Path URI
        deriving Show
newtype FPath  = FPath URI
        deriving Show

data HSPath = S3P S3Path | FP FPath
     deriving Show
data FromTo = FromTo HSPath HSPath
     deriving Show

data S3Response = Get S3.GetObjectResponse | Put S3.PutObjectResponse

-- * Commandline args, messaging.
version :: String
version = "v0.1.0.0"

whoami, greeting, usage :: String
whoami   = "hs3 simple s3 file upload / download utility."
usage    = "\nhs3 <from_uri> <to_uri>"
greeting = whoami ++ version ++ usage

defineFlag "v:verbose" False "Verbose output."

s3Prefix :: String
s3Prefix = "s3://"

say :: String -> IO ()
say = putStrLn

ifv :: Monad m => m () -> m ()
ifv e = when flags_verbose e

parsePaths :: String -> String -> Maybe FromTo
parsePaths p1 p2 =
  case parseS3URI p1  of -- one and only one of p1, p2 is a s3:// uri.
   Just s3uri -> do
     furi <- parseURIReference p2
     return $ FromTo (S3P $ S3Path s3uri)  (FP $ FPath furi)
   Nothing -> do
     furi <- parseURIReference p1
     s3uri <- parseS3URI p2
     return $ FromTo (FP $ FPath furi) (S3P $ S3Path s3uri)
  where
    s3scheme uri = uriScheme uri == "s3:" && hasBucket uri
    hasBucket uri = isJust $ do
      auth <- uriAuthority uri
      return $ uriRegName auth
    parseS3URI uri =
      case parseURI uri of
        (Just s3uri) | s3scheme s3uri -> Just s3uri
        _ -> Nothing

checkPaths :: [String] -> IO FromTo
checkPaths [p1, p2] = do
  case parsePaths p1 p2  of
    Just ps -> return ps
    Nothing -> do
      putStrLn "One and only one path must be in the form of an s3 uri. \
                                   \e.g s3://bucket/b.dat"
      exitFailure
checkPaths _ = do
   putStrLn "Two paths are required, e.g. hs3 /tmp/a.dat s3://bucket/b.dat"
   exitFailure

s3BucketPath :: S3Path -> (S3.Bucket, FilePath)
s3BucketPath (S3Path s3uri) =
  let bucket = pack $ getBucket s3uri
      bpath  = uriPath s3uri
  in (bucket, drop 1 bpath)
  where
   getBucket = uriRegName . fromJust . uriAuthority

showFetch :: S3.Bucket -> FilePath -> FilePath -> IO ()
showFetch bucket bpath fpath = do
  say $ "Fetching from bucket " ++ b ++ " at " ++ bpath ++ " to " ++ fpath
  where
   b = unpack bucket

responseMessage :: S3Response -> String
responseMessage rsp =
  case rsp of
    Put r -> show $ r
    Get (S3.GetObjectResponse meta _) -> show meta

-- -- * Fetch a file from S3.

simpleFetch :: S3Path -> FPath -> IO S3.GetObjectResponse
simpleFetch s3uri (FPath furi)  = do
  cfg <- Aws.baseConfiguration
  let (bucket, bpath) = s3BucketPath s3uri
  let localpath = uriPath furi
  ifv $ showFetch bucket bpath localpath
  let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery
  withManager $ \mgr -> do
    grsp@S3.GetObjectResponse { S3.gorResponse = rsp } <-
      Aws.pureAws cfg s3cfg mgr $ S3.getObject bucket (pack bpath)
    responseBody rsp $$+- sinkFile localpath
    return grsp

-- * Store a file up on S3.

simpleStore :: FPath -> S3Path -> IO S3.PutObjectResponse
simpleStore (FPath furi)  s3uri = do
  awscfg <- Aws.baseConfiguration
  let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery
  let (bucket, bpath) = s3BucketPath s3uri
  let fpath = uriPath furi
  IO.withFile fpath  IO.ReadMode $ \hIn -> do
    bytes <- BL.hGetContents hIn
    withManager $ \mgr -> do
      let req = S3.putObject bucket (pack bpath) (RequestBodyLBS bytes)
      resp <- Aws.aws awscfg s3cfg mgr req
      Aws.readResponseIO resp

-- | Move up/down a file.
s3MoveFile :: FromTo -> IO S3Response
s3MoveFile (FromTo (S3P s3uri) (FP furi)) = do
  rsp <- simpleFetch s3uri furi
  return $ Get rsp
s3MoveFile (FromTo (FP furi) (S3P s3uri)) = do
  rsp <- simpleStore furi s3uri
  return $ Put rsp
s3MoveFile _ = do
  putStrLn "From to paths must be one S3 uri and one local file path."
  exitFailure

main :: IO ()
main = do
    args   <- $initHFlags greeting
    fromto <- checkPaths args
    rsp    <- s3MoveFile fromto
    ifv (say $ responseMessage rsp)

