{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveDataTypeable #-}


module Regfish
    ( dump
    , login
    , list
    , add
    , edit
    , del
    ) where

import Control.Lens
import Control.Monad.IO.Class
import Data.Default
import Data.Monoid
import qualified Data.Acid as A
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy.Char8 as LBS8
import qualified Data.List as L
import qualified Network.HTTP.Client as C
import qualified Network.Wreq as W
import qualified Network.Wreq.Types as W (Postable)
import Regfish.AcidState
import Regfish.Default ()
import Regfish.Parser
import Regfish.Types
import Text.Printf


loginUrl :: Url
loginUrl = "https://www.regfish.de/my/login"


sessionCookieName :: BS8.ByteString
sessionCookieName = "rf51"


sessionToken :: C.CookieJar -> Maybe SessionToken
sessionToken =
    fmap C.cookie_value .
    L.find ((==sessionCookieName) . C.cookie_name) .
    C.destroyCookieJar


responseSessionToken :: Getter (W.Response body) (Maybe SessionToken)
responseSessionToken =
    W.responseCookieJar . to sessionToken

dump :: IO ()
dump =
    withLocalState def $ \qa -> do
        print =<< A.query qa DumpQuery


login :: IO ()
login =
    withLocalState def $ \qa -> do

        cj <- A.query qa CookieJarQuery

        putStrLn $ "session token: " <> show (sessionToken cj)

        putStrLn $ "Logging in..."

        res <- liftIO $ W.post loginUrl
            [ "u" W.:= _username def
            , "p" W.:= _password def
            ]

        putStrLn $ "session token: " <> show (res ^. responseSessionToken)

        A.update qa $ CookieJarUpdate $ res ^. W.responseCookieJar


list :: IO ()
list =
    regfishGet (_allinone def) >>= \case
        Left err -> error err
        Right r -> do
            let body = r ^. W.responseBody
            if isLoginPage $ LBS8.unpack body
                then do
                    -- TODO login and try again (once)
                    error "not logged in"
                else do
                    mapM_ pr $ readZone $ body
  where
    pr (Record rrid rrtype rrname rrttl rraux rrdata) = do
        printf "%-8s %-24s\t%s\tIN\t%-5s\t%s\n"
                  rrid
                  rrname
                  (if rrttl /= 0 then show rrttl else mempty)
                  rrtype $
                  (if rraux /= 0 then show rraux <> " " else mempty)
                  <> rrdata



regfishGet :: Url -> IO (Either String (W.Response LBS8.ByteString))
regfishGet url =
    withLocalState def $ \qa -> do

        cj <- A.query qa CookieJarQuery

        --putStrLn $ "session token: " <> show (sessionToken cj)

        case sessionToken cj of
            Nothing -> do
                putStrLn "Not logged in."
                -- TODO log in
                return $ Left "not logged in"

            Just _ -> do
                --putStrLn $ "GET " <> url

                let opts = W.defaults & W.cookies .~ cj

                res <- liftIO $ W.getWith opts url

                --now <- getCurrentTime

                --putStrLn $ "session token: " <> show (res ^. W.responseCookieJar . to sessionToken)

                let cj' = res ^. W.responseCookieJar
                    --cj'' = C.evictExpiredCookies cj' now

                A.update qa $ CookieJarUpdate cj'

                return $ Right res


regfishPost :: W.Postable p =>
    Url -> p -> IO (Either String (W.Response LBS8.ByteString))
regfishPost url params = do
    withLocalState def $ \qa -> do

        cj <- A.query qa CookieJarQuery

        --putStrLn $ "session token: " <> show (sessionToken cj)

        case sessionToken cj of
            Nothing -> do
                putStrLn "Not logged in."
                -- TODO log in
                return $ Left "not logged in"

            Just _ -> do
                --putStrLn $ "POST " <> url <> " " <> show params

                let opts = W.defaults & W.cookies .~ cj

                res <- liftIO $ W.postWith opts url params

                -- TODO check error

                --putStrLn $ "session token: " <> show (res ^. W.responseCookieJar . to sessionToken)

                A.update qa $ CookieJarUpdate $ res ^. W.responseCookieJar

                return $ Right res



-- | We're on a login page, when a form action is `loginUrl`.
isLoginPage :: String -> Bool
isLoginPage =
    (("action=" ++ show loginUrl) `L.isInfixOf`)



undata :: RRData -> (String -> Integer -> String -> a) -> a
undata (A rrdata) f = f "A" 0 rrdata
undata (MX rraux rrdata) f = f "MX" rraux rrdata
undata (CNAME rrdata) f = f "CNAME" 0 rrdata

add :: RRname -> RRttl -> RRData -> IO (Either String (W.Response LBS8.ByteString))
add rrname rrttl rrdata =
    regfishPost (_allinone def) $ undata rrdata $ getRRAddValidation rrname rrttl

edit :: RRid -> RRname -> RRttl -> RRData -> IO (Either String (W.Response LBS8.ByteString))
edit rrid rrname rrttl rrdata =
    regfishPost (_allinone def) $ undata rrdata $ commitRRChanges rrid rrname rrttl

del :: RRid -> IO (Either String (W.Response LBS8.ByteString))
del rrid =
    regfishPost (_allinone def) $ removeRREntry rrid



removeRREntry :: RRid -> [W.FormParam]
removeRREntry rrid =
    [ "action"  W.:= ("removeRREntry" :: String)
    , "rrid"  W.:= rrid
    ]

commitRRChanges ::
    RRid -> RRname -> RRttl -> RRtype -> RRaux -> RRdata -> [W.FormParam]
commitRRChanges rrid rrname rrttl rrtype rraux rrdata =
    [ "action"  W.:= ("commitRRChanges" :: String)
    , "rrid"  W.:= rrid
    , "type"  W.:= rrtype
    , "name"  W.:= rrname
    , "ttl"   W.:= rrttl
    , "data"  W.:= rrdata
    , "aux"   W.:= rraux
    ]

getRRAddValidation ::
    RRname -> RRttl -> RRtype -> RRaux -> RRdata -> [W.FormParam]
getRRAddValidation rrname rrttl rrtype rraux rrdata =
    [ "action"  W.:= ("getRRAddValidation" :: String)
    , "type"  W.:= rrtype
    , "name"  W.:= rrname
    , "ttl"   W.:= rrttl
    , "data"  W.:= rrdata
    , "aux"   W.:= rraux
    ]