<commit_before>{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE ViewPatterns               #-}

-- Module      : Khan.Internal.Types
-- Copyright   : (c) 2013 <NAME> <<EMAIL>>
-- License     : This Source Code Form is subject to the terms of
--               the Mozilla Public License, v. 2.0.
--               A copy of the MPL can be found in the LICENSE file or
--               you can obtain it at http://mozilla.org/MPL/2.0/.
-- Maintainer  : <NAME> <<EMAIL>>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)

module Khan.Internal.Types
   (
   -- * Aliases
     EnvMap

   -- * Classes
   , Invalid       (..)
   , ToEnv         (..)
   , Naming        (..)

   -- * Types
   , Modified      (..)
   , Ann           (..)
   , Tags          (..)
   , Names         (..)
   , RoutingPolicy (..)
   , TrustPath     (..)
   , PolicyPath    (..)
   , Env           (_env)
   , Role          (_role)

   -- * Smart constructors
   , versioned
   , unversioned
   , newEnv
   , newRole

   -- * Ghetto lenses
   , modified

   -- * Text helpers
   , regionToText
   , stripText
   ) where

import           Data.Aeson
import           Data.Aeson.Types             (Options(..), defaultOptions)
import           Data.HashMap.Strict          (HashMap)
import qualified Data.HashMap.Strict          as Map
import           Data.Hashable
import           Data.SemVer
import           Data.String
import qualified Data.Text                    as Text
import qualified Data.Text.Lazy               as LText
import qualified Data.Text.Lazy.Builder       as Build
import qualified Filesystem.Path.CurrentOS    as Path
import           GHC.Generics                 (Generic)
import           Khan.Prelude
import           Network.AWS                  (Region)
import qualified Text.ParserCombinators.ReadP as ReadP
import           Text.Read
import qualified Text.Read                    as Read

type EnvMap = HashMap Text Text

data Modified a
    = Changed   { result :: !a }
    | Unchanged { result :: !a }
      deriving (Eq, Show)

modified :: Modified a -> Bool
modified (Changed _) = True
modified _           = False

class Invalid a where
    invalid :: a -> Bool
    valid   :: a -> Bool

    valid = not . invalid

instance Invalid Bool where
    invalid = id

instance Invalid Text where
    invalid = Text.null

instance Invalid a => Invalid [a] where
    invalid [] = True
    invalid xs = invalid `any` xs

instance Invalid (NonEmpty a) where
    invalid _ = False

instance Invalid Char where
    invalid _ = False

instance Invalid FilePath where
    invalid f
        | Path.null f = True
        | otherwise   = not $ Path.valid f

instance Invalid a => Invalid (Maybe a) where
    invalid (Just x) = invalid x
    invalid Nothing  = True

instance Invalid Region where
    invalid _ = False

class ToEnv a where
    toEnv     :: a -> HashMap Text Text
    renderEnv :: Bool -> a -> LText.Text

    renderEnv multi = Build.toLazyText
        . Map.foldrWithKey (key suffix) mempty
        . toEnv
      where
        suffix
            | multi     = Build.singleton '\n'
            | otherwise = Build.singleton ' '

        key suf k v = mappend
            ( Build.fromText k
           <> Build.singleton '='
           <> Build.fromText v
           <> suf
            )

instance ToEnv (Text, Text) where
    toEnv = Map.fromList . (:[])

instance ToEnv (HashMap Text Text) where
    toEnv = id

data Ann a = Ann
    { annValue :: a
    , annTags  :: Tags
    }

data Tags = Tags
    { tagRole    :: !Role
    , tagEnv     :: !Env
    , tagDomain  :: !Text
    , tagName    :: Maybe Text
    , tagVersion :: Maybe Version
    , tagWeight  :: !Int
    , tagGroup   :: Maybe Text
    } deriving (Eq, Ord, Show)

instance ToEnv Tags where
    toEnv Tags{..} = Map.fromList $
        [ ("KHAN_ROLE", _role tagRole)
        , ("KHAN_ENV", _env tagEnv)
        , ("KHAN_DOMAIN", tagDomain)
        -- Removed due to caching (see Tag.cached) which means a certain amount
        -- of immutability is required.
        --  , ("KHAN_WEIGHT", Text.pack $ show tagWeight)
        ] ++ maybeToList (("KHAN_VERSION",) . showVersion <$> tagVersion)
          ++ maybeToList (("KHAN_NAME",) <$> tagName)

instance Naming Tags where
    names Tags{..} = createNames tagRole tagEnv tagVersion

data Names = Names
    { envName          :: !Text
    , keyName          :: !Text
    , roleName         :: !Text
    , profileName      :: !Text
    , groupName        :: !Text
    , imageName        :: !Text
    , appName          :: !Text
    , balancerBaseName :: !Text
    , dnsName          :: !Text
    , versionName      :: Maybe Text
    } deriving (Eq, Ord, Show, Generic)

instance Hashable Names

instance ToJSON Names where
    toJSON = genericToJSON $ defaultOptions<commit_msg>Expanding upon removal of KHAN_WEIGHT from sourceable environment output<commit_after>{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE ViewPatterns               #-}

-- Module      : Khan.Internal.Types
-- Copyright   : (c) 2013 <NAME> <<EMAIL>>
-- License     : This Source Code Form is subject to the terms of
--               the Mozilla Public License, v. 2.0.
--               A copy of the MPL can be found in the LICENSE file or
--               you can obtain it at http://mozilla.org/MPL/2.0/.
-- Maintainer  : <NAME> <<EMAIL>>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)

module Khan.Internal.Types
   (
   -- * Aliases
     EnvMap

   -- * Classes
   , Invalid       (..)
   , ToEnv         (..)
   , Naming        (..)

   -- * Types
   , Modified      (..)
   , Ann           (..)
   , Tags          (..)
   , Names         (..)
   , RoutingPolicy (..)
   , TrustPath     (..)
   , PolicyPath    (..)
   , Env           (_env)
   , Role          (_role)

   -- * Smart constructors
   , versioned
   , unversioned
   , newEnv
   , newRole

   -- * Ghetto lenses
   , modified

   -- * Text helpers
   , regionToText
   , stripText
   ) where

import           Data.Aeson
import           Data.Aeson.Types             (Options(..), defaultOptions)
import           Data.HashMap.Strict          (HashMap)
import qualified Data.HashMap.Strict          as Map
import           Data.Hashable
import           Data.SemVer
import           Data.String
import qualified Data.Text                    as Text
import qualified Data.Text.Lazy               as LText
import qualified Data.Text.Lazy.Builder       as Build
import qualified Filesystem.Path.CurrentOS    as Path
import           GHC.Generics                 (Generic)
import           Khan.Prelude
import           Network.AWS                  (Region)
import qualified Text.ParserCombinators.ReadP as ReadP
import           Text.Read
import qualified Text.Read                    as Read

type EnvMap = HashMap Text Text

data Modified a
    = Changed   { result :: !a }
    | Unchanged { result :: !a }
      deriving (Eq, Show)

modified :: Modified a -> Bool
modified (Changed _) = True
modified _           = False

class Invalid a where
    invalid :: a -> Bool
    valid   :: a -> Bool

    valid = not . invalid

instance Invalid Bool where
    invalid = id

instance Invalid Text where
    invalid = Text.null

instance Invalid a => Invalid [a] where
    invalid [] = True
    invalid xs = invalid `any` xs

instance Invalid (NonEmpty a) where
    invalid _ = False

instance Invalid Char where
    invalid _ = False

instance Invalid FilePath where
    invalid f
        | Path.null f = True
        | otherwise   = not $ Path.valid f

instance Invalid a => Invalid (Maybe a) where
    invalid (Just x) = invalid x
    invalid Nothing  = True

instance Invalid Region where
    invalid _ = False

class ToEnv a where
    toEnv     :: a -> HashMap Text Text
    renderEnv :: Bool -> a -> LText.Text

    renderEnv multi = Build.toLazyText
        . Map.foldrWithKey (key suffix) mempty
        . toEnv
      where
        suffix
            | multi     = Build.singleton '\n'
            | otherwise = Build.singleton ' '

        key suf k v = mappend
            ( Build.fromText k
           <> Build.singleton '='
           <> Build.fromText v
           <> suf
            )

instance ToEnv (Text, Text) where
    toEnv = Map.fromList . (:[])

instance ToEnv (HashMap Text Text) where
    toEnv = id

data Ann a = Ann
    { annValue :: a
    , annTags  :: Tags
    }

data Tags = Tags
    { tagRole    :: !Role
    , tagEnv     :: !Env
    , tagDomain  :: !Text
    , tagName    :: Maybe Text
    , tagVersion :: Maybe Version
    , tagWeight  :: !Int
    , tagGroup   :: Maybe Text
    } deriving (Eq, Ord, Show)

-- Compatibility note:
-- Weight has been removed from the tag->sourceable environment output due to
-- to caching (see Tag.cached).
--
-- This is because of requiring the cached output's input to be immutable,
-- which KHAN_WEIGHT does not guarantee.
instance ToEnv Tags where
    toEnv Tags{..} = Map.fromList $
        [ ("KHAN_ROLE", _role tagRole)
        , ("KHAN_ENV", _env tagEnv)
        , ("KHAN_DOMAIN", tagDomain)
        ] ++ maybeToList (("KHAN_VERSION",) . showVersion <$> tagVersion)
          ++ maybeToList (("KHAN_NAME",) <$> tagName)

instance Naming Tags where
    names Tags{..} = createNames tagRole tagEnv tagVersion

data Names = Names
    { envName          :: !Text
    , keyName          :: !Text
    , roleName         :: !Text
    , profileName      :: !Text
    , groupName        :: !Text
    , imageName        :: !Text
    , appName          :: !Text
    , balancerBaseName :: !Text
    , dnsName          :: !Text
    , versionName      :: Maybe Text
    } deriving (Eq, Ord, Show, Generic)

instance Hashable Names

instance ToJSON Names where
    toJSON = genericToJSON $ defaultOptions
{'fraction_non_alphanumeric': 0.10045573547949191, 'fraction_numerical': 0.0015514399301852031, 'mean_word_length': 1.7823037496628, 'pattern_counts': {'":': 0, '<': 25, '<?xml version=': 0, '>': 42, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '7630184', 'n_tokens_mistral': 3089, 'n_tokens_neox': 2999, 'n_words': 922}