{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where

import Control.Concurrent.MVar
import Control.Exception (handle)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as Char8
import qualified Data.ByteString.Lazy.Char8 as LChar8
import Data.Maybe (maybeToList)
import Data.String (fromString)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy.Encoding as TLE
import Data.Word (Word8)
import qualified Network.HTTP.Client as N
import qualified Network.HTTP.Client.TLS as N
import qualified Network.HTTP.Types.Status as N
import System.Environment (getArgs)
import System.Exit (die)
import System.IO (hFlush, stdout)

import Ghci
import IRC


urlQueryComponentEncode :: Text -> TL.Text
urlQueryComponentEncode = TLB.toLazyText . foldMap f . BS.unpack . TE.encodeUtf8
  where
    f :: Word8 -> TLB.Builder
    f c | c >= 0x80 = percent c
        | otherwise = let spec = table `BS.index` fromIntegral c
                      in if spec == fromIntegral (fromEnum '%')
                           then percent c
                           else TLB.singleton (toEnum (fromIntegral spec))

    percent :: Word8 -> TLB.Builder
    percent c =
      let n = fromIntegral c
      in TLB.singleton '%' <> TLB.singleton (hexdigit (n `quot` 16))
                           <> TLB.singleton (hexdigit (n `rem` 16))

    hexdigit :: Int -> Char
    hexdigit n | n < 10 = toEnum (fromEnum '0' + n)
               | otherwise = toEnum (fromEnum 'A' + n - 10)

    -- obtained by observing what curl does
    table :: BS.ByteString
    table = Char8.pack $ concat
      ["%%%%%%%%%%%%%%%%"  -- 0x00 - 0x0f
      ,"%%%%%%%%%%%%%%%%"  -- 0x10 - 0x1f
      ,"+%%%%%%%%%%%%-.%"  --  !"#$%&'()*+,-./
      ,"0123456789%%%%%%"  -- 0123456789:;<=>?
      ,"%ABCDEFGHIJKLMNO"  -- @ABCDEFGHIJKLMNO
      ,"PQRSTUVWXYZ%%%%i"  -- PQRSTUVWXYZ[\]^_
      ,"%abcdefghijklmno"  -- `abcdefghijklmno
      ,"pqrstuvwxyz%%%~%"] -- pqrstuvwxyz{|}~

pastePostErrorString :: String
pastePostErrorString = "Pasting failed, sorry -- use plain % instead"

-- Given text to be pasted, return paste url if successful, error otherwise
makePaste :: N.Manager -> Text -> IO (Either String Text)
makePaste mgr bodytext =
  let nreq = N.defaultRequest
        { N.host = Char8.pack "paste.tomsmeding.com"
        , N.port = 443
        , N.secure = True
        , N.method = Char8.pack "POST"
        , N.path = Char8.pack "/paste"
        , N.requestHeaders = [(fromString "Content-Type"
                              ,fromString "application/x-www-form-urlencoded")]
        , N.requestBody = N.RequestBodyLBS $
            LChar8.pack "expire=day&name1=&code1="
            <> TLE.encodeUtf8 (urlQueryComponentEncode bodytext)
        , N.redirectCount = 0  -- the redirect is precisely what we want to catch
        }
  in handle (\(e :: N.HttpException) -> print e >> return (Left pastePostErrorString)) $
     N.withResponse nreq mgr $ \response -> do
       case N.statusCode (N.responseStatus response) of
         303
           | Just url <- lookup (fromString "location") (N.responseHeaders response)
           -> return (Right (T.pack "https://paste.tomsmeding.com"
                             <> TE.decodeUtf8Lenient url))
         429 -> do
           return (Left "Pastebin rate-limited")
         _ -> do
           putStrLn $ "Paste response status " ++ show (N.responseStatus response) ++ " /= 200"
           return (Left pastePostErrorString)


runInGhci :: Ghci -> ParseSettings -> Text -> IO (Ghci, Maybe Text)
runInGhci ghci pset message = do
  (ghci', output) <- runStmtClever ghci pset (T.unpack message)
  case output of
    Error "" -> return (ghci', Just (T.pack "Error?"))
    Error err -> return (ghci', Just (T.pack err))
    Ignored -> return (ghci', Nothing)
    Return "" -> return (ghci', Just (T.pack "<no output>"))
    Return s -> return (ghci', Just (T.pack s))
    Exited -> return (ghci', Just (T.pack "<bye>"))

data ReqKind = Reply | Paste
  deriving (Show)

mainIRC :: IO ()
mainIRC = do
  ghci0 <- makeGhci
  ghcivar <- newMVar ghci0
  manager <- N.newTlsManager
  connectIRC
    (\t -> if | T.take 2 t == T.pack "% " -> Just (Reply, T.drop 2 t)
              | T.take 3 t == T.pack "%% " -> Just (Paste, T.drop 3 t)
              | otherwise -> Nothing)
    (\(kind, expression) recvmsg -> do
      putStrLn $ "Responding to " ++ T.unpack recvmsg
      hFlush stdout
      ghci <- takeMVar ghcivar
      let pset = case kind of Reply -> parseSettingsReply
                              Paste -> parseSettingsPaste
      (ghci', msgs) <- runInGhci ghci pset expression
      putMVar ghcivar ghci'
      case kind of
        Reply -> return (maybeToList msgs)
        Paste -> case msgs of
          Nothing -> return [T.pack "Nothing to paste"]
          Just msg -> makePaste manager msg >>= \case
            Left err -> return [T.pack err]
            Right url -> return [url])

mainGHCI :: IO ()
mainGHCI = do
  let loop :: Ghci -> IO ()
      loop ghci = do
        line <- getLine
        (ghci', moutput) <- runStmtClever ghci parseSettingsReply line
        case moutput of
          Return output -> putStrLn $ "output = <" ++ output ++ ">"
          Ignored -> putStrLn "<ignored>"
          Error err -> putStrLn err
          Exited -> putStrLn $ "<exited>"
        loop ghci'
  makeGhci >>= loop

main :: IO ()
main = do
  getArgs >>= \case
    ["-irc"] -> mainIRC
    ["-ghci"] -> mainGHCI
    [] -> mainGHCI
    _ -> die "Command line not recognised"