{-# LANGUAGE RecordWildCards, FlexibleContexts, FlexibleInstances, OverloadedStrings #-}
module Clckwrks.Redirect.Plugin where

import Clckwrks                     ( ClckwrksConfig(clckTopDir), ClckState(plugins), ClckT(..), ClckURL, ClckPlugins, Theme
                                    , Role(..), ClckPluginsSt, addAdminMenu, addNavBarCallback, addPreProc, query, update
                                    )
import Clckwrks.Acid                (GetUACCT(..), SetUACCT(..))
import Clckwrks.Plugin              (clckPlugin)
import Clckwrks.Redirect.Acid       (RedirectState, initialRedirectState)
import Clckwrks.Redirect.Monad      (RedirectConfig(..), runRedirectT)
import Clckwrks.Redirect.Route      (routeRedirect)
import Clckwrks.Redirect.URL        (RedirectURL(..), RedirectAdminURL(..))
import Clckwrks.Redirect.Types      ()
import Control.Applicative          ((<$>))
import Control.Monad.State          (get)
import Data.Acid                    (AcidState)
import Data.Acid.Advanced           (update', query')
import Data.Acid.Local              (createCheckpointAndClose, openLocalStateFrom,)
import Data.Char              (ord)
import Data.List              (intersperse)
import Data.Monoid            ((<>))
import Data.String            (fromString)
import qualified Data.Text    as Text
import Data.Text                    (Text)
import Data.Text.Lazy         (toStrict)
import qualified Data.Text.Lazy     as TL
import Data.Text.Lazy.Builder (Builder, fromText, singleton, toLazyText)
import Data.Typeable                (Typeable)
import Data.Maybe                   (fromMaybe)
import Data.Set                     (Set)
import qualified Data.Set           as Set
import Numeric                (showIntAtBase)
import Happstack.Server             (ServerPartT, Response, seeOther, notFound, toResponse)
-- import System.Directory             (createDirectoryIfMissing)
import System.FilePath              ((</>))
import Web.Routes                   (toPathSegments, parseSegments, withRouteT, fromPathSegments)
import Web.Plugins.Core             (Plugin(..), Plugins(..), When(..), addCleanup, addHandler, addPostHook, addPluginRouteFn, initPlugin, getConfig, getPluginRouteFn)

redirectHandler :: (RedirectURL -> [(Text, Maybe Text)] -> Text)
                -> RedirectConfig
                -> ClckPlugins
                -> [Text]
                -> ClckT ClckURL (ServerPartT IO) Response
redirectHandler showRedirectURL redirectConfig plugins paths =
    case parseSegments fromPathSegments paths of
      (Left e)  -> notFound $ toResponse (show e)
      (Right u) ->
          ClckT $ withRouteT flattenURL $ unClckT $ runRedirectT redirectConfig $ routeRedirect u
    where
      flattenURL ::   ((url' -> [(Text, Maybe Text)] -> Text) -> (RedirectURL -> [(Text, Maybe Text)] -> Text))
      flattenURL _ u p = showRedirectURL u p

redirectInit :: ClckPlugins
         -> IO (Maybe Text)
redirectInit plugins =
    do (Just redirectShowFn) <- getPluginRouteFn plugins (pluginName redirectPlugin)
       (Just clckShowFn)     <- getPluginRouteFn plugins (pluginName clckPlugin)
       mTopDir <- clckTopDir <$> getConfig plugins
       let basePath = maybe "_state" (\td -> td </> "_state") mTopDir -- FIXME
           redirectDir  = maybe "_redirect" (\td -> td </> "_redirect") mTopDir

       irs  <- initialRedirectState
       acid <- openLocalStateFrom (basePath </> "redirect") irs
       addCleanup plugins Always (createCheckpointAndClose acid)

       let redirectConfig = RedirectConfig { redirectState     = acid
                                           , redirectClckURL   = clckShowFn
                                           }

--       addPreProc plugins (redirectCmd acid redirectShowFn)
--       addNavBarCallback plugins (navBarCallback acid redirectShowFn)
       addHandler plugins (pluginName redirectPlugin) (redirectHandler redirectShowFn redirectConfig)
--       addPostHook plugins (migrateUACCT acid)

       return Nothing

addRedirectAdminMenu :: ClckT url IO ()
addRedirectAdminMenu =
    do p <- plugins <$> get
       -- (Just redirectShowURL) <- getPluginRouteFn p (pluginName redirectPlugin)
       addAdminMenu ( "Redirect/Rewrites"
                    , [ (Set.fromList [Administrator, Editor], "Redirects", "")
                      ]
                    )
       pure ()
{-
       let newRedirectURL    = pageShowURL (PageAdmin NewPage) []
           pagesURL      = pageShowURL (PageAdmin Pages) []
           feedConfigURL = pageShowURL (PageAdmin EditFeedConfig) []
       addAdminMenu ("Pages/Posts"
                    , [ (Set.fromList [Administrator, Editor], "New Page/Post"   , newRedirectURL)
                      , (Set.fromList [Administrator, Editor], "Edit Page/Post"  , pagesURL)
                      , (Set.fromList [Administrator, Editor], "Edit Feed Config", feedConfigURL)
                      ]
                    )
-}
redirectPlugin :: Plugin RedirectURL Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt
redirectPlugin = Plugin
    { pluginName           = "redirect"
    , pluginInit           = redirectInit
    , pluginDepends        = ["clck"]
    , pluginToPathSegments = toPathSegments
    , pluginPostHook       = addRedirectAdminMenu
    }

plugin :: ClckPlugins -- ^ plugins
       -> Text        -- ^ baseURI
       -> IO (Maybe Text)
plugin plugins baseURI =
    initPlugin plugins baseURI redirectPlugin

-- | initialize the redirect plugin
--
-- we can not use the standard `initPlugin` function for the redirect plugin because we want to intercept URLs higher up the chain.
initRedirectPlugin ::
              Plugins Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt    -- ^ 'Plugins' handle
           -> Text                              -- ^ base URI to prepend to generated URLs
           -> IO (Maybe Text)                   -- ^ possible error message
initRedirectPlugin plugins baseURI =
    do -- putStrLn $ "initializing " ++ (Text.unpack pluginName)
       let (Plugin{..}) = redirectPlugin
       addPluginRouteFn plugins pluginName baseURI pluginToPathSegments -- (\u p ->  {- <> "/" <> {- pluginToPathInfo u <> -} paramsToQueryString (map (\(k, v) -> (k, fromMaybe mempty v)) p)-})
       addPostHook plugins pluginPostHook
       pluginInit plugins

paramsToQueryString :: [(Text, Text)] -> Text
paramsToQueryString [] = mempty
paramsToQueryString ps = toStrictText $ "?" <> mconcat (intersperse "&" (map paramToQueryString ps) )
    where
      toStrictText = toStrict . toLazyText

      isAlphaChar :: Char -> Bool
      isAlphaChar c    = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')

      isDigitChar :: Char -> Bool
      isDigitChar c    = (c >= '0' && c <= '9')

      isOk :: Char -> Bool
      isOk c = isAlphaChar c || isDigitChar c || elem c (":@$-_.~" :: String)

      escapeChar c
          | c == ' '  = singleton '+'
          | isOk c    = singleton c
          | otherwise = "%" <>
                        let hexDigit n
                                | n <= 9 = head (show n)
                                | n == 10 = 'A'
                                | n == 11 = 'B'
                                | n == 12 = 'C'
                                | n == 13 = 'D'
                                | n == 14 = 'E'
                                | n == 15 = 'F'
                        in case showIntAtBase 16 hexDigit (ord c) "" of
                             []  -> "00"
                             [x] -> fromString ['0',x]
                             cs  -> fromString cs

      escapeParam :: Text -> Builder
      escapeParam p = Text.foldr (\c cs -> escapeChar c <> cs) mempty p

      paramToQueryString :: (Text, Text) -> Builder
      paramToQueryString (k,v) = (escapeParam k) <> "=" <> (escapeParam v)