{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE OverloadedStrings #-}

module Network.Octohat.Types ( Member(..)
                             , MemberWithKey(..)
                             , Team(..)
                             , TeamPermission(..)
                             , Repo(..)
                             , Organization(..)
                             , BearerToken(..)
                             , OrganizationName(..)
                             , TeamName(..)
                             , StatusInTeam(..)
                             , EmptyBody(..)
                             , DidDelete(..)
                             , PublicKey(..)
                             , PublicKeyFingerprint(..)
                             , TeamCreateRequest(..)
                             , GitHubReturnStatus(..)
                             , DidAddKey(..)
                             , AddPublicKeyRequest(..)
                             , runGitHub
                             , runGitHub'
                             , GitHub) where
import Control.Applicative
import Control.Monad.Reader (ReaderT(..))
import Control.Monad.Trans.Either
import Data.Aeson
import Data.Aeson.TH
import Data.Char (toLower)
import Network.HTTP.Client
import Network.Wreq.Types
import System.Environment.Compat (lookupEnv)
import qualified Data.HashMap.Strict as HS
import qualified Data.Text as T

-- | Represents a user in GitHub. Contains no more than login and user ID
data Member =
  Member { memberLogin :: T.Text
         , memberId    :: Integer
         } deriving (Show, Eq)

-- | Represents the different permissions that a team can have in an organisation.
data TeamPermission = OwnerAccess    -- ^ Default team of owners.
                    | PullAccess     -- ^ This team will be able to view and clone its
                                     --   repositories.
                    | PushAccess     -- ^ This team will be able to read its 
                                     --   repositories, as well as push to them.
                    | AdminAccess    -- ^ This team will be able to push/pull to its
                                     --   repositories, as well as add other 
                                     --   collaborators to them. 
                    deriving (Show,Eq)

-- | Represents a team in GitHub. Contains the team's ID, the team's name and an optional description
data Team =
  Team { teamId          :: Integer
       , teamName        :: T.Text
       , teamDescription :: Maybe T.Text
       , teamPermission  :: TeamPermission
       } deriving (Show, Eq)

-- | Represents a request to create a new team within an organization. The rest of the paramaters
--   are passed in the URL. Refer to <https://developer.github.com/v3/orgs/teams/#create-team>
data TeamCreateRequest =
  TeamCreateRequest { newTeamName        :: T.Text
                    , newTeamDescription :: T.Text
                    , newTeamPermission  :: TeamPermission
                    } deriving (Show, Eq)

-- | Represents an organisation in GitHub. Only has  name and description
data Organization =
  Organization 
       { orgLogin       :: T.Text
       , orgDescription :: Maybe T.Text
       } deriving (Show, Eq)

-- | Represents a repo in GitHub. Contains the Name, Description, and Private status
data Repo =
  Repo { repoName        :: T.Text
       , repoDescription :: Maybe T.Text
       , repoPrivate     :: Bool
       } deriving (Show, Eq)

-- | Represents a GitHub user with its public keys and fingerprints. A GitHub user might or might not
--   have any public keys
data MemberWithKey =
  MemberWithKey { member               :: Member
                , memberKey            :: [PublicKey]
                , memberKeyFingerprint :: [PublicKeyFingerprint]
                } deriving (Show, Eq)

-- | Represents a PublicKey within GitHub. It includes its ID and the public key encoded as base 64
data PublicKey =
  PublicKey { publicKeyId    :: Integer
            , publicKey      :: T.Text
            } deriving (Show, Eq)

-- | Represents a Fingerprint. The `fingerprintId` field should match the fingerprint's public key ID
--   within GitHub
data PublicKeyFingerprint =
  PublicKeyFingerprint { fingerprintId        :: Integer
                       , publicKeyFingerprint :: T.Text
                       } deriving (Show, Eq)

-- | Some Wreq functions expect a body, but often GitHub's API will request no body. The PUT verb
--   and its implementation in Wreq is an example of this.
data EmptyBody = EmptyBody deriving (Show, Eq)

-- | When adding a user to a team GitHub will add it immediately if the user already belongs to the
--   to the organization the team is in. Otherwise it will send an email for the user to accept the
--   request to join the team. Functions related adding or removing teams will return either Active
--   or Pending correspondingly.
data StatusInTeam = Active  | Pending deriving (Show, Eq)


-- | Sum type to represent the success or failure of deletion of a resource within GitHub's API
data DidDelete = Deleted | NotDeleted deriving (Show, Eq)

instance FromJSON PublicKey where
  parseJSON (Object o) = PublicKey <$> o .: "id" <*> o .: "key"
  parseJSON _          = fail "Could not find public keys in document"

data DidAddKey = KeyAdded | KeyNotAdded

data AddPublicKeyRequest =
  AddPublicKeyRequest {
      addPublicKeyRequestKey   :: T.Text,
      addPublicKeyRequestTitle :: T.Text
  }

instance FromJSON StatusInTeam where
  parseJSON (Object o) =
    case HS.lookup "state" o of
      Just "active"  -> pure Active
      Just "pending" -> pure Pending
      Just _         -> fail "\"state\" key not \"active\" or \"pending\""
      Nothing        -> (fail . maybe "No error message from GitHub" show) (HS.lookup "message" o)
  parseJSON _         = fail "Expected a membership document, got something else"

instance FromJSON TeamPermission where
  parseJSON (String p) = 
    case p of
      "pull"         -> pure PullAccess
      "push"         -> pure PushAccess
      "admin"        -> pure AdminAccess
      "owner"        -> pure OwnerAccess
      _              -> fail "Expected a valid team permission ?"
  parseJSON _         = fail "Expected a team permssion, got something else"

instance ToJSON TeamPermission where
  toJSON p = 
    case p of 
      PullAccess   -> String "pull"
      PushAccess   -> String "push"
      AdminAccess  -> String "admin"
      OwnerAccess  -> String "owner"


$(deriveJSON defaultOptions { fieldLabelModifier = drop 6  . map toLower } ''Member)
$(deriveJSON defaultOptions { fieldLabelModifier = drop 4  . map toLower } ''Team)
$(deriveJSON defaultOptions { fieldLabelModifier = drop 4  . map toLower } ''Repo)
$(deriveJSON defaultOptions { fieldLabelModifier = drop 3  . map toLower } ''Organization)
$(deriveJSON defaultOptions { fieldLabelModifier = drop 7  . map toLower } ''TeamCreateRequest)
$(deriveJSON defaultOptions { fieldLabelModifier = drop 19 . map toLower } ''AddPublicKeyRequest)

-- | Error codes GitHub might return when attempting to use an API endpoint
data GitHubReturnStatus =   InvalidJSON             -- ^ GitHub could not parse the JSON document sent
                          | ValidationFailed        -- ^ Validation failed, an example of this error
                                                    --   is trying to create teams with the same name
                                                    --   within one organization
                          | InternalError           -- ^ In case GitHub returns 500 Internal Server Error
                                                    --   to some request
                          | NotFound                -- ^ When a resource has not been found. It does not
                                                    --   imply the resource does not exist
                          | NotAllowed              -- ^ Usually returned after GitHub replies with 403 Forbidden.
                                                    --   The user might not have permission to access/modify
                                                    --   that resource
                          | AllOk                   -- ^ This should never be returned
                          | RequiresAuthentication  -- ^ Accesing this resource requires authentication
                          | UnexpectedJSON String   -- ^ This library has failed to fulfill its purpose and could not
                                                    --   handle GitHub's response
                          deriving (Show, Eq)

-- | Instance that does not add anything to the body or headers of a PUT request
instance Putable EmptyBody where
  putPayload EmptyBody req = return $ req {requestBody = RequestBodyLBS ""}

instance Postable TeamCreateRequest where
  postPayload createRequest req = return $ req { requestBody = RequestBodyLBS (encode createRequest)}

instance Postable AddPublicKeyRequest where
  postPayload createRequest req = return $ req { requestBody = RequestBodyLBS (encode createRequest)}

-- | GitHub's OAuth 2.0 bearer token. This is simply added in an
--   Authorization header
newtype BearerToken = BearerToken { unBearerToken :: T.Text } deriving Show

-- | OrganizationName is added in order to have type safety in functions where the
--   Organization name and the Team name are both strings and may be confused
newtype OrganizationName = OrganizationName { unOrganizationName :: T.Text } deriving Show

-- | TeamName is added in order to have type safety in functions where the
--   Team name and the Organization name are both strings and may be confused
newtype TeamName = TeamName { unTeamName :: T.Text } deriving Show

-- | The monad transformer where all operations run. Supports initial configuration
--   through a Reader monad and the possibility of failure through Either
type GitHub = EitherT GitHubReturnStatus (ReaderT BearerToken IO)

-- | Executes a computation built within the GitHub monad returning an Either within
--   the IO data type using the provided token
runGitHub' :: GitHub a -> BearerToken -> IO (Either GitHubReturnStatus a)
runGitHub' comp = runReaderT (runEitherT comp)

-- | Executes a computation built within the GitHub monad returning an Either within
--   the IO data type. Reads an API token from an environment variable named GITHUB_TOKEN
runGitHub :: GitHub a -> IO (Either GitHubReturnStatus a)
runGitHub comp = do
  maybeToken <- lookupEnv "GITHUB_TOKEN"
  case maybeToken of
    Just acquiredToken -> runGitHub' comp (BearerToken $ T.pack acquiredToken)
    Nothing            -> fail "Couldn't find GITHUB_TOKEN in environment"