{-# LANGUAGE OverloadedStrings,TemplateHaskell #-}
{-|
Module      : IP2LocationWebService
Description : IP2Location Haskell package
Copyright   : (c) IP2Location, 2021
License     : MIT
Maintainer  : sales@ip2location.com
Stability   : experimental

This Haskell package allows users to query an IP address to get geolocation info.

IP2Location Web Service API subscription at https://www.ip2location.com/web-service/ip2location
-}
module IP2LocationWebService (WSResult(..), WSConfig, openWS, lookUp, getCredit) where

import Control.Exception
import System.Exit
import Data.Aeson as DA
import Data.Aeson.TH
import Network.HTTP.Client
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types.Status (statusCode)
import Data.Maybe
import Network.URI.Encode as URIE
import Data.List.Split
import Data.ByteString.Lazy as BS (ByteString, unpack)
import Data.Char (chr)

-- | Contains the web service configuration.

data WSConfig = WSConfig {
    -- | Web service API key

    WSConfig -> String
apiKey :: String,
    -- | API package

    WSConfig -> String
apiPackage :: String,
    -- | Use SSL

    WSConfig -> Bool
useSSL :: Bool
} deriving (Int -> WSConfig -> ShowS
[WSConfig] -> ShowS
WSConfig -> String
(Int -> WSConfig -> ShowS)
-> (WSConfig -> String) -> ([WSConfig] -> ShowS) -> Show WSConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WSConfig] -> ShowS
$cshowList :: [WSConfig] -> ShowS
show :: WSConfig -> String
$cshow :: WSConfig -> String
showsPrec :: Int -> WSConfig -> ShowS
$cshowsPrec :: Int -> WSConfig -> ShowS
Show)

-- | Contains the web service results.

data WSResult = WSResult {
    -- | Response status or error

    WSResult -> String
response :: String,
    -- | Country code

    WSResult -> Maybe String
country_code :: Maybe String,
    -- | Country name

    WSResult -> Maybe String
country_name :: Maybe String,
    -- | Region name

    WSResult -> Maybe String
region_name :: Maybe String,
    -- | City name

    WSResult -> Maybe String
city_name :: Maybe String,
    -- | Latitude

    WSResult -> Maybe Float
latitude :: Maybe Float,
    -- | Longitude

    WSResult -> Maybe Float
longitude :: Maybe Float,
    -- | ZIP code

    WSResult -> Maybe String
zip_code :: Maybe String,
    -- | Time zone

    WSResult -> Maybe String
time_zone :: Maybe String,
    -- | ISP name

    WSResult -> Maybe String
isp :: Maybe String,
    -- | Domain

    WSResult -> Maybe String
domain :: Maybe String,
    -- | Net speed

    WSResult -> Maybe String
net_speed :: Maybe String,
    -- | IDD code

    WSResult -> Maybe String
idd_code :: Maybe String,
    -- | Area code

    WSResult -> Maybe String
area_code :: Maybe String,
    -- | Weather station code

    WSResult -> Maybe String
weather_station_code :: Maybe String,
    -- | Weather station name

    WSResult -> Maybe String
weather_station_name :: Maybe String,
    -- | MCC

    WSResult -> Maybe String
mcc :: Maybe String,
    -- | MNC

    WSResult -> Maybe String
mnc :: Maybe String,
    -- | Mobile brand

    WSResult -> Maybe String
mobile_brand :: Maybe String,
    -- | Elevation

    WSResult -> Maybe Float
elevation :: Maybe Float,
    -- | Usage type

    WSResult -> Maybe String
usage_type :: Maybe String,
    -- | Address type

    WSResult -> Maybe String
address_type :: Maybe String,
    -- | IAB category code

    WSResult -> Maybe String
category :: Maybe String,
    -- | IAB category name

    WSResult -> Maybe String
category_name :: Maybe String,
    -- | Credits consumed

    WSResult -> Maybe Float
credits_consumed :: Maybe Float
} deriving (Int -> WSResult -> ShowS
[WSResult] -> ShowS
WSResult -> String
(Int -> WSResult -> ShowS)
-> (WSResult -> String) -> ([WSResult] -> ShowS) -> Show WSResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WSResult] -> ShowS
$cshowList :: [WSResult] -> ShowS
show :: WSResult -> String
$cshow :: WSResult -> String
showsPrec :: Int -> WSResult -> ShowS
$cshowsPrec :: Int -> WSResult -> ShowS
Show, WSResult -> WSResult -> Bool
(WSResult -> WSResult -> Bool)
-> (WSResult -> WSResult -> Bool) -> Eq WSResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WSResult -> WSResult -> Bool
$c/= :: WSResult -> WSResult -> Bool
== :: WSResult -> WSResult -> Bool
$c== :: WSResult -> WSResult -> Bool
Eq)

$(deriveJSON defaultOptions ''WSResult)

checkparams :: String -> String -> IO String
checkparams :: String -> String -> IO String
checkparams String
apikey String
apipackage = do
    String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"OK"
    --- regex part commented out due to cabal dependency issues

    -- let apikeyok = apikey =~ ("^[0-9A-Z]{10}$" :: String) :: Bool

    -- if apikeyok == False

        -- then die(show "Invalid API key.")

        -- else do

            -- let apipackageok = apipackage =~ ("^WS[0-9]+$" :: String) :: Bool

            -- if apipackageok == False

                -- then die(show "Invalid package name.")

                -- else return "OK"


{-|
    The 'openWS' function initializes the web service configuration.
    It takes 3 arguments; the web service API key, the API package to call & whether to use SSL.
-}
openWS :: String -> String -> Bool -> IO WSConfig
openWS :: String -> String -> Bool -> IO WSConfig
openWS String
apikey String
apipackage Bool
usessl = do
    String
paramok <- String -> String -> IO String
checkparams String
apikey String
apipackage
    WSConfig -> IO WSConfig
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String -> Bool -> WSConfig
WSConfig String
apikey String
apipackage Bool
usessl)

{-|
    The 'lookUp' function returns an WSResult containing geolocation data for an IP address
    It takes 2 arguments; the web service configuration from 'openWS' function (WSConfig record), either IPv4 or IPv6 address (String)
-}
lookUp :: WSConfig -> String -> IO WSResult
lookUp :: WSConfig -> String -> IO WSResult
lookUp WSConfig
myconfig String
ip = do
    let key :: String
key = WSConfig -> String
apiKey WSConfig
myconfig
    let package :: String
package = WSConfig -> String
apiPackage WSConfig
myconfig
    let usessl :: Bool
usessl = WSConfig -> Bool
useSSL WSConfig
myconfig

    String
paramok <- String -> String -> IO String
checkparams String
key String
package
    let protocol :: String
protocol = if Bool
usessl Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
True
        then String
"https"
        else String
"http"
    Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
    Request
httprequest <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (String -> IO Request) -> String -> IO Request
forall a b. (a -> b) -> a -> b
$ String
protocol String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"://api.ip2location.com/v2/?key=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
key String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"&package=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
package String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"&ip=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (ShowS
URIE.encode String
ip)
    Response ByteString
httpresponse <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
httprequest Manager
manager
    let json :: ByteString
json = Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
httpresponse
    let Just WSResult
result = ByteString -> Maybe WSResult
forall a. FromJSON a => ByteString -> Maybe a
DA.decode ByteString
json :: Maybe WSResult
    WSResult -> IO WSResult
forall (m :: * -> *) a. Monad m => a -> m a
return WSResult
result

bsToString :: BS.ByteString -> String
bsToString :: ByteString -> String
bsToString ByteString
bs = (Word8 -> Char) -> [Word8] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a. Enum a => a -> Int
fromEnum) ([Word8] -> String)
-> (ByteString -> [Word8]) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString
bs

{-|
    The 'getCredit' function returns an IO String containing web service credit balance for the API key.
    It takes 1 argument; the web service configuration from 'openWS' function (WSConfig record).
-}
getCredit :: WSConfig -> IO String
getCredit :: WSConfig -> IO String
getCredit WSConfig
myconfig = do
    let key :: String
key = WSConfig -> String
apiKey WSConfig
myconfig
    let package :: String
package = WSConfig -> String
apiPackage WSConfig
myconfig
    let usessl :: Bool
usessl = WSConfig -> Bool
useSSL WSConfig
myconfig

    String
paramok <- String -> String -> IO String
checkparams String
key String
package
    let protocol :: String
protocol = if Bool
usessl Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
True
        then String
"https"
        else String
"http"
    Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
    Request
httprequest <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (String -> IO Request) -> String -> IO Request
forall a b. (a -> b) -> a -> b
$ String
protocol String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"://api.ip2location.com/v2/?key=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
key String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"&check=true"
    Response ByteString
httpresponse <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
httprequest Manager
manager
    let json :: ByteString
json = Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
httpresponse
    -- using splitOn to extract the response field to bypass the Haskell duplicate field name issues

    let part :: String
part = [String] -> String
forall a. [a] -> a
head (String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"}" (ByteString -> String
bsToString ByteString
json))
    let result :: String
result = [String] -> String
forall a. [a] -> a
last (String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
":" String
part)
    String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
result