    {-# LANGUAGE CPP                        #-}
    {-# LANGUAGE BangPatterns               #-}
    {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    {-# LANGUAGE ImpredicativeTypes         #-}
    {-# LANGUAGE MultiParamTypeClasses      #-}
    {-# LANGUAGE OverloadedStrings          #-}
    {-# LANGUAGE TemplateHaskell            #-}
    {-# LANGUAGE FlexibleInstances          #-}

    #ifndef MIN_VERSION_comonad
    #define MIN_VERSION_comonad(x,y,z) 1
    #endif

    module Snap.Snaplet.Internal.Types where

    import           Control.Applicative
    import           Control.Lens
    import           Control.Monad.CatchIO hiding (Handler)
    import           Control.Monad.Reader
    import           Control.Monad.State.Class
    import           Control.Monad.Trans.Either
    import           Control.Monad.Trans.Writer hiding (pass)
    import           Data.ByteString (ByteString)
    import qualified Data.ByteString.Char8 as B
    import           Data.Configurator.Types
    import           Data.IORef
    import           Data.Monoid
    import           Data.Text (Text)

    import           Snap.Core
    import qualified Snap.Snaplet.Internal.LensT as LT
    import qualified Snap.Snaplet.Internal.Lensed as L

    ------------------------------------------------------------------------------
    -- | An opaque data type holding internal snaplet configuration data.  It is
    -- exported publicly because the getOpaqueConfig function in MonadSnaplet
    -- makes implementing new instances of MonadSnaplet more convenient.
    data SnapletConfig = SnapletConfig
        { _scAncestry        :: [Text]
        , _scFilePath        :: FilePath
        , _scId              :: Maybe Text
        , _scDescription     :: Text
        , _scUserConfig      :: Config
        , _scRouteContext    :: [ByteString]
        , _scRoutePattern    :: Maybe ByteString
            -- ^ Holds the actual route pattern passed to addRoutes for the
            -- current handler.  Nothing during initialization and before route
            -- dispatech.
        , _reloader          :: IO (Either Text Text) -- might change
            -- ^ This is the universal reload action for the top-level site.  We
            -- can't update this in place to be a reloader for each individual
            -- snaplet because individual snaplets can't be reloaded in isolation
            -- without losing effects that subsequent hooks may have had.
        }

    makeLenses ''SnapletConfig

    ------------------------------------------------------------------------------
    -- | Joins a reversed list of directories into a path.
    buildPath :: [ByteString] -> ByteString
    buildPath ps = B.intercalate "/" $ filter (not . B.null) $ reverse ps

    ------------------------------------------------------------------------------
    -- | Joins a reversed list of directories into a path.
    getRootURL :: SnapletConfig -> ByteString
    getRootURL sc = buildPath $ _scRouteContext sc

    ------------------------------------------------------------------------------
    -- | Snaplet's type parameter 's' here is user-defined and can be any Haskell
    -- type.  A value of type @Snaplet s@ countains a couple of things:
    --
    -- * a value of type @s@, called the \"user state\".
    --
    -- * some bookkeeping data the framework uses to plug things together, like
    --   the snaplet's configuration, the snaplet's root directory on the
    --   filesystem, the snaplet's root URL, and so on.
    data Snaplet s = Snaplet
        { _snapletConfig   :: SnapletConfig
        , _snapletModifier :: s -> IO ()
            -- ^ See the _reloader comment for why we have to use this to reload
            -- single snaplets in isolation.  This action won't actually run the
            -- initializer at all.  It will only modify the existing state.  It is
            -- the responsibility of the snaplet author to avoid using this in
            -- situations where it will destroy data in its state that was created
            -- by subsequent hook actions.
        , _snapletValue    :: s
        }

    makeLenses ''Snaplet

    --instance Functor Snaplet where
    --  fmap f (Snaplet c r a) = Snaplet c r (f a)
    --
    --instance Foldable Snaplet where
    --  foldMap f (Snaplet _ _ a) = f a
    --
    --instance Traversable Snaplet where
    --  traverse f (Snaplet c r a) = Snaplet c r <$> f a
    --
    --instance Comonad Snaplet where
    --  extract (Snaplet _ _ a) = a
    --
    -- #if !(MIN_VERSION_comonad(3,0,0))
    -- instance Extend Snaplet where
    -- #endif
    --   extend f w@(Snaplet c r _) = Snaplet c r (f w)

    {-
    ------------------------------------------------------------------------------
    -- | A lens referencing the opaque SnapletConfig data type held inside
    -- Snaplet.
    snapletConfig :: SimpleLens (Snaplet a) SnapletConfig

    ------------------------------------------------------------------------------
    -- | A lens referencing the user-defined state type wrapped by a Snaplet.
    snapletValue :: SimpleLens (Snaplet a) a
    -}

    type SnapletLens s a = ALens' s (Snaplet a)

    ------------------------------------------------------------------------------
    -- | Transforms a lens of the type you get from makeLenses to an similar lens
    -- that is more suitable for internal use.
    subSnaplet :: SnapletLens a b
               -> SnapletLens (Snaplet a) b
    subSnaplet l = snapletValue . l

    ------------------------------------------------------------------------------
    -- | The m type parameter used in the MonadSnaplet type signatures will
    -- usually be either Initializer or Handler, but other monads may sometimes be
    -- useful.
    --
    -- Minimal complete definition:
    --
    -- * 'withTop'', 'with'', 'getLens', and 'getOpaqueConfig'.
    --
    class MonadSnaplet m where
        -- | Runs a child snaplet action in the current snaplet's context.  If you
        -- think about snaplet lenses using a filesystem path metaphor, the lens
        -- supplied to this snaplet must be a relative path.  In other words, the
        -- lens's base state must be the same as the current snaplet.
        with :: SnapletLens v v'
                 -- ^ A relative lens identifying a snaplet
             -> m b v' a
                 -- ^ Action from the lense's snaplet
             -> m b v a
        with l = with' (subSnaplet l)

        -- | Like 'with' but doesn't impose the requirement that the action
        -- being run be a descendant of the current snaplet.  Using our filesystem
        -- metaphor again, the lens for this function must be an absolute
        -- path--it's base must be the same as the current base.
        withTop :: SnapletLens b v'
                    -- ^ An \"absolute\" lens identifying a snaplet
                -> m b v' a
                    -- ^ Action from the lense's snaplet
                -> m b v a
        withTop l = withTop' (subSnaplet l)

        -- | A variant of 'with' accepting a lens from snaplet to snaplet.  Unlike
        -- the lens used in the above 'with' function, this lens formulation has
        -- an identity, which makes it useful in certain circumstances.  The
        -- lenses generated by 'makeLenses' will not work with this function,
        -- however the lens returned by 'getLens' will.
        --
        -- @with = with' . subSnaplet@
        with' :: SnapletLens (Snaplet v) v'
              -> m b v' a -> m b v a

        -- Not providing a definition for this function in terms of withTop'
        -- allows us to avoid extra Monad type class constraints, making the type
        -- signature easier to read.
        -- with' l m = flip withTop m . (l .) =<< getLens

        -- | The absolute version of 'with''
        withTop' :: SnapletLens (Snaplet b) v'
                 -> m b v' a -> m b v a

        -- | Gets the lens for the current snaplet.
        getLens :: m b v (SnapletLens (Snaplet b) v)

        -- | Gets the current snaplet's opaque config data type.  You'll only use
        -- this function when writing MonadSnaplet instances.
        getOpaqueConfig :: m b v SnapletConfig
        -- NOTE: We can't just use a MonadState (Snaplet v) instance for this
        -- because Initializer has SnapletConfig, but doesn't have a full Snaplet.

    ------------------------------------------------------------------------------
    -- | Gets a list of the names of snaplets that are direct ancestors of the
    -- current snaplet.
    getSnapletAncestry :: (Monad (m b v), MonadSnaplet m) => m b v [Text]
    getSnapletAncestry = return . _scAncestry =<< getOpaqueConfig

    ------------------------------------------------------------------------------
    -- | Gets the snaplet's path on the filesystem.
    getSnapletFilePath :: (Monad (m b v), MonadSnaplet m) => m b v FilePath
    getSnapletFilePath = return . _scFilePath =<< getOpaqueConfig

    ------------------------------------------------------------------------------
    -- | Gets the current snaple's name.
    getSnapletName :: (Monad (m b v), MonadSnaplet m) => m b v (Maybe Text)
    getSnapletName = return . _scId =<< getOpaqueConfig

    ------------------------------------------------------------------------------
    -- | Gets a human readable description of the snaplet.
    getSnapletDescription :: (Monad (m b v), MonadSnaplet m) => m b v Text
    getSnapletDescription = return . _scDescription =<< getOpaqueConfig

    ------------------------------------------------------------------------------
    -- | Gets the config data structure for the current snaplet.
    getSnapletUserConfig :: (Monad (m b v), MonadSnaplet m) => m b v Config
    getSnapletUserConfig = return . _scUserConfig =<< getOpaqueConfig

    ------------------------------------------------------------------------------
    -- | Gets the base URL for the current snaplet.  Directories get added to
    -- the current snaplet path by calls to 'nestSnaplet'.
    getSnapletRootURL :: (Monad (m b v), MonadSnaplet m) => m b v ByteString
    getSnapletRootURL = liftM getRootURL getOpaqueConfig

    ------------------------------------------------------------------------------
    -- | Constructs a url relative to the current snaplet.
    snapletURL :: (Monad (m b v), MonadSnaplet m)
               => ByteString -> m b v ByteString
    snapletURL suffix = do
        cfg <- getOpaqueConfig
        return $ buildPath (cleanSuffix : _scRouteContext cfg)
      where
        dropSlash = B.dropWhile (=='/')
        cleanSuffix = B.reverse $ dropSlash $ B.reverse $ dropSlash suffix

    ------------------------------------------------------------------------------
    -- | Snaplet infrastructure is available during runtime request processing
    -- through the Handler monad.  There aren't very many standalone functions to
    -- read about here, but this is deceptive.  The key is in the type class
    -- instances.  Handler is an instance of 'MonadSnap', which means it is the
    -- monad you will use to write all your application routes.  It also has a
    -- 'MonadSnaplet' instance, which gives you all the functionality described
    -- above.
    newtype Handler b v a =
        Handler (L.Lensed (Snaplet b) (Snaplet v) Snap a)
      deriving ( Monad
               , Functor
               , Applicative
               , MonadIO
               , MonadPlus
               , MonadCatchIO
               , Alternative
               , MonadSnap)

    ------------------------------------------------------------------------------
    -- | Gets the @Snaplet v@ from the current snaplet's state.
    getSnapletState :: Handler b v (Snaplet v)
    getSnapletState = Handler get

    ------------------------------------------------------------------------------
    -- | Puts a new @Snaplet v@ in the current snaplet's state.
    putSnapletState :: Snaplet v -> Handler b v ()
    putSnapletState = Handler . put

    ------------------------------------------------------------------------------
    -- | Modifies the @Snaplet v@ in the current snaplet's state.
    modifySnapletState :: (Snaplet v -> Snaplet v) -> Handler b v ()
    modifySnapletState f = do
        s <- getSnapletState
        putSnapletState (f s)

    ------------------------------------------------------------------------------
    -- | Gets the @Snaplet v@ from the current snaplet's state and applies a
    -- function to it.
    getsSnapletState :: (Snaplet v -> b) -> Handler b1 v b
    getsSnapletState f = do
        s <- getSnapletState
        return (f s)

    ------------------------------------------------------------------------------
    -- | The MonadState instance gives you access to the current snaplet's state.
    instance MonadState v (Handler b v) where
        get = getsSnapletState _snapletValue
        put v = modifySnapletState (set snapletValue v)

    ------------------------------------------------------------------------------
    -- | The MonadState instance gives you access to the current snaplet's state.
    instance MonadReader v (Handler b v) where
        ask = getsSnapletState _snapletValue
        local f m = do
            cur <- ask
            put (f cur)
            res <- m
            put cur
            return res

    instance MonadSnaplet Handler where
        getLens = Handler ask
        with' !l (Handler !m) = Handler $ L.with l m
        withTop' !l (Handler m) = Handler $ L.withTop l m
        getOpaqueConfig = Handler $ gets _snapletConfig

    ------------------------------------------------------------------------------
    -- | Like 'runBase', but it doesn't require an MVar to be executed.
    runPureBase :: Handler b b a -> Snaplet b -> Snap a
    runPureBase (Handler m) b = do
            (!a, _) <- L.runLensed m id b
            return $! a

    ------------------------------------------------------------------------------
    -- | Gets the route pattern that matched for the handler.  This lets you find
    -- out exactly which of the strings you used in addRoutes matched.
    getRoutePattern :: Handler b v (Maybe ByteString)
    getRoutePattern =
        withTop' id $ liftM _scRoutePattern getOpaqueConfig

    ------------------------------------------------------------------------------
    -- | Sets the route pattern that matched for the handler.  Use this when to
    -- override the default pattern which is the key to the alist passed to
    -- addRoutes.
    setRoutePattern :: ByteString -> Handler b v ()
    setRoutePattern p = withTop' id $
        modifySnapletState (set (snapletConfig . scRoutePattern) (Just p))

    ------------------------------------------------------------------------------
    -- | Pass if the request is not coming from localhost.
    failIfNotLocal :: MonadSnap m => m b -> m b
    failIfNotLocal m = do
        -- FIXME: this moves to auth once control-panel is done
        rip <- liftM rqRemoteAddr getRequest
        if not $ elem rip [ "127.0.0.1"
                          , "localhost"
                          , "::1" ]
          then pass
          else m

    ------------------------------------------------------------------------------
    -- | Handler that reloads the site.
    reloadSite :: Handler b v ()
    reloadSite = failIfNotLocal $ do
        cfg <- getOpaqueConfig
        !res <- liftIO $ _reloader cfg
        either bad good res
      where
        bad msg = do
            writeText $ "Error reloading site!\n\n"
            writeText msg
        good msg = do
            writeText msg
            writeText $ "Site successfully reloaded.\n"

    ------------------------------------------------------------------------------
    -- | This function brackets a Handler action in resource acquisition and
    -- release.  Like 'bracketSnap',  this is provided because MonadCatchIO's
    -- 'bracket' function doesn't work properly in the case of a short-circuit
    -- return from the action being bracketed.
    --
    -- In order to prevent confusion regarding the effects of the
    -- aquisition and release actions on the Handler state, this function
    -- doesn't accept Handler actions for the acquire or release actions.
    --
    -- This function will run the release action in all cases where the
    -- acquire action succeeded.  This includes the following behaviors
    -- from the bracketed Snap action.
    --
    -- 1. Normal completion
    --
    -- 2. Short-circuit completion, either from calling 'fail' or 'finishWith'
    --
    -- 3. An exception being thrown.
    bracketHandler :: IO a -> (a -> IO x) -> (a -> Handler b v c) -> Handler b v c
    bracketHandler begin end f = Handler . L.Lensed $ \l v b -> do
        bracketSnap begin end $ \a -> case f a of Handler m -> L.unlensed m l v b

    ------------------------------------------------------------------------------
    -- | Information about a partially constructed initializer.  Used to
    -- automatically aggregate handlers and cleanup actions.
    data InitializerState b = InitializerState
        { _isTopLevel      :: Bool
        , _cleanup         :: IORef (IO ())
        , _handlers        :: [(ByteString, Handler b b ())]
            -- ^ Handler routes built up and passed to route.
        , _hFilter         :: Handler b b () -> Handler b b ()
            -- ^ Generic filtering of handlers
        , _curConfig       :: SnapletConfig
            -- ^ This snaplet config is the incrementally built config for
            -- whatever snaplet is currently being constructed.
        , _initMessages    :: IORef Text
        , _environment     :: String
        , masterReloader   :: (Snaplet b -> Snaplet b) -> IO ()
            -- ^ We can't just hae a simple MVar here because MVars can't be
            -- chrooted.
        }

    ------------------------------------------------------------------------------
    -- | Wrapper around IO actions that modify state elements created during
    -- initialization.
    newtype Hook a = Hook (Snaplet a -> EitherT Text IO (Snaplet a))

    instance Monoid (Hook a) where
        mempty = Hook return
        (Hook a) `mappend` (Hook b) = Hook (a >=> b)

    ------------------------------------------------------------------------------
    -- | Monad used for initializing snaplets.
    newtype Initializer b v a =
        Initializer (LT.LensT (Snaplet b)
                              (Snaplet v)
                              (InitializerState b)
                              (WriterT (Hook b) IO)
                              a)
      deriving (Applicative, Functor, Monad, MonadIO)

    makeLenses ''InitializerState

    instance MonadSnaplet Initializer where
        getLens = Initializer ask
        with' !l (Initializer !m) = Initializer $ LT.with l m
        withTop' !l (Initializer m) = Initializer $ LT.withTop l m
        getOpaqueConfig = Initializer $ liftM _curConfig LT.getBase

    ------------------------------------------------------------------------------
    -- | Opaque newtype which gives us compile-time guarantees that the user is
    -- using makeSnaplet and either nestSnaplet or embedSnaplet correctly.
    newtype SnapletInit b v = SnapletInit (Initializer b v (Snaplet v))