{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
module SketeServer where

import Servant

import Data.Maybe
import Control.Monad
import Control.Monad.Trans
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wai as WAI
import qualified Network.Wai.Middleware.RequestLogger as WAI
import qualified Network.Wai.Handler.Warp as Warp
import System.FilePath (joinPath)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Control.DeepSeq
import Text.Read
import Web.Routes
import Web.Routes.Wai
import qualified Text.Parsec as P
import qualified Codec.Compression.GZip as GZ
import Data.Default.Class

import Distribution.Skete.Storage.Interface (PackageVersion(..))
import qualified Distribution.Skete.Storage.Interface as Storage
import qualified Distribution.Skete.Storage.GitFat as GitFat
import Distribution.Skete.TarUtils
import Distribution.Skete.Haskell.Package

-- | Don't mind me. I'm just a lowly orphan
instance FromHttpApiData PackageVersion where
  parseUrlPiece token =
    maybe
      (Left "Unable to parse package version")
      Right $ T.stripSuffix ".tar.gz" token >>= (readMaybe . T.unpack)

type API =
       "packages" :> "archive" :> "00-index.tar.gz" :> Get '[OctetStream] BSL.ByteString
  :<|> "packages" :> "archive" :> Capture "PackageVersion" PackageVersion :> Get '[OctetStream] BSL.ByteString

server' :: GitFat.GitFatConfig -> Server API
server' ss = serveIndexH ss :<|> serveTarH ss

serveTarH :: GitFat.GitFatConfig -> PackageVersion -> Handler BSL.ByteString 
serveTarH ss pid = do
  mResult <- (Storage.storage ss :: GitFat.GitFat p a -> Handler a) $ do
    mr <- Storage.lookup pid
    case mr of
      Nothing -> return Nothing
      Just pr -> do
        dt <- Storage.versionFiles pr
        return $ Just $
          GZ.compressWith (GZ.defaultCompressParams { GZ.compressLevel = GZ.bestSpeed }) .
            implodeTar $ dt
  maybe
    (throwError $ err404 { errBody = "I will not give you what you want" })
    return $ mResult

serveIndexH :: GitFat.GitFatConfig -> Handler BSL.ByteString
serveIndexH ss =
  (Storage.storage ss :: GitFat.GitFat p a -> Handler a) $ do
    let ps = "all"
    pis <- Storage.list ps
    (snd . createIndexTar . catMaybes) <$> (forM pis $ \pid -> do
      mc <- Storage.labelDataLookup ps pid "cabal"
      case mc of
        Nothing -> return Nothing
        Just r -> r `deepseq` do
          return $ Just (joinPath [ T.unpack . pvName $ pid
                                  , show . pvVersion $ pid
                                  , (T.unpack . pvName $ pid) ++ ".cabal"], BSL.fromStrict r))

data SiteMap =
    PackageIndex
  | Package PackageVersion
  deriving (Show, Eq, Ord)

type UrlMaker = SiteMap -> [(T.Text, Maybe T.Text)] -> T.Text

genURL :: SiteMap -> [T.Text]
genURL PackageIndex = ["packages", "archive", "00-index.tar.gz"]
genURL (Package a) = ["packages", "archive", "package", (T.pack $ show a) `T.append` ".tar.gz"]

parseURL :: URLParser SiteMap
parseURL =
    P.choice $ map P.try [
        pPackageIndex
      , pPackageTar
      ]
  where
    pPackageIndex = do
      void $ segment "packages"
      void $ segment "archive"
      void $ segment "00-index.tar.gz"
      P.eof
      return PackageIndex
    pPackageTar = do
      void $ segment "packages"
      void $ segment "archive"
      void $ segment "package"
      pv <- pToken ("bad package-version"::String) (\t -> T.stripSuffix ".tar.gz" t >>= (readMaybe . T.unpack))
      return $ Package pv

instance PathInfo SiteMap where
  toPathSegments = genURL
  fromPathSegments = parseURL

server :: IO ()
server = do
  let ss = GitFat.GFC. TE.encodeUtf8 $ ".git"
  logger <- WAI.mkRequestLogger def
  Warp.run 8080 $ logger (handleWai (TE.encodeUtf8 "") $
    \_ sm ->
    case sm of
      PackageIndex -> serveIndex ss
      Package pv -> serveTar ss pv)

serveTar :: GitFat.GitFatConfig -> PackageVersion -> WAI.Application
serveTar ss pid _ respond = (Storage.storage ss::GitFat.GitFat p a -> IO a) $ do
  mr <- Storage.lookup pid
  case mr of
    Nothing -> do
      liftIO . respond . WAI.responseLBS HTTP.status404 [] $ "I will not give you what you want"
    Just pr -> do
      dt <- Storage.versionFiles pr
      liftIO . respond . WAI.responseLBS HTTP.status200 [] .
        GZ.compressWith (GZ.defaultCompressParams { GZ.compressLevel = GZ.bestSpeed }) .
        implodeTar $ dt

serveIndex :: GitFat.GitFatConfig -> WAI.Application
serveIndex ss _ respond = (Storage.storage ss::GitFat.GitFat p a -> IO a) $ do
  let ps = "all"
  pis <- Storage.list ps
  index <- (snd . createIndexTar . catMaybes) <$> (forM pis $ \pid -> do
    mc <- Storage.labelDataLookup ps pid "cabal"
    case mc of
      Nothing -> return Nothing
      Just r -> r `deepseq` do
        return $ Just (joinPath [ T.unpack . pvName $ pid
                                , show . pvVersion $ pid
                                , (T.unpack . pvName $ pid) ++ ".cabal"], BSL.fromStrict r))
  liftIO . respond . WAI.responseLBS HTTP.status200 [] $ index