module Metro.Socket
  ( Socket
  , close
  , listen
  , connect
  , getHost
  , getService
  -- udp
  , bindTo
  , getDatagramAddr
  ) where

import           Control.Exception (bracketOnError, throwIO)
import           Control.Monad     (when)
import           Data.List         (isPrefixOf)
import           Data.Maybe        (listToMaybe)
import           Network.Socket    hiding (bind, connect, listen)
import qualified Network.Socket    as S (bind, connect, listen)
import           System.Directory  (doesFileExist, removeFile)
import           System.Exit       (exitFailure)
import           UnliftIO          (tryIO)

-- Returns the first action from a list which does not throw an exception.
-- If all the actions throw exceptions (and the list of actions is not empty),
-- the last exception is thrown.
-- The operations are run outside of the catchIO cleanup handler because
-- catchIO masks asynchronous exceptions in the cleanup handler.
-- In the case of complete failure, the last exception is actually thrown.
firstSuccessful :: [IO a] -> IO a
firstSuccessful :: [IO a] -> IO a
firstSuccessful = Maybe IOException -> [IO a] -> IO a
forall b. Maybe IOException -> [IO b] -> IO b
go Maybe IOException
forall a. Maybe a
Nothing
  where
  -- Attempt the next operation, remember exception on failure
  go :: Maybe IOException -> [IO b] -> IO b
go Maybe IOException
_ (IO b
p:[IO b]
ps) =
    do Either IOException b
r <- IO b -> IO (Either IOException b)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
tryIO IO b
p
       case Either IOException b
r of
         Right b
x -> b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
x
         Left  IOException
e -> Maybe IOException -> [IO b] -> IO b
go (IOException -> Maybe IOException
forall a. a -> Maybe a
Just IOException
e) [IO b]
ps

  -- All operations failed, throw error if one exists
  go Maybe IOException
Nothing  [] = [Char] -> IO b
forall a. HasCallStack => [Char] -> a
error [Char]
"firstSuccessful: empty list"
  go (Just IOException
e) [] = IOException -> IO b
forall e a. Exception e => e -> IO a
throwIO IOException
e


connectTo :: Maybe HostName -> Maybe ServiceName -> IO Socket
connectTo :: Maybe [Char] -> Maybe [Char] -> IO Socket
connectTo Maybe [Char]
host Maybe [Char]
serv = do
    let hints :: AddrInfo
hints = AddrInfo
defaultHints { addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_ADDRCONFIG]
                             , addrSocketType :: SocketType
addrSocketType = SocketType
Stream }
    [AddrInfo]
addrs <- Maybe AddrInfo -> Maybe [Char] -> Maybe [Char] -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) Maybe [Char]
host Maybe [Char]
serv
    [IO Socket] -> IO Socket
forall a. [IO a] -> IO a
firstSuccessful ([IO Socket] -> IO Socket) -> [IO Socket] -> IO Socket
forall a b. (a -> b) -> a -> b
$ (AddrInfo -> IO Socket) -> [AddrInfo] -> [IO Socket]
forall a b. (a -> b) -> [a] -> [b]
map AddrInfo -> IO Socket
tryToConnect [AddrInfo]
addrs
  where
  tryToConnect :: AddrInfo -> IO Socket
tryToConnect AddrInfo
addr =
    IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Socket) -> IO Socket
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
        (Family -> SocketType -> ProtocolNumber -> IO Socket
socket (AddrInfo -> Family
addrFamily AddrInfo
addr) (AddrInfo -> SocketType
addrSocketType AddrInfo
addr) (AddrInfo -> ProtocolNumber
addrProtocol AddrInfo
addr))
        Socket -> IO ()
close  -- only done if there's an error
        (\Socket
sock -> do
          Socket -> SockAddr -> IO ()
S.connect Socket
sock (AddrInfo -> SockAddr
addrAddress AddrInfo
addr)
          Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock
        )

connectToFile :: FilePath -> IO Socket
connectToFile :: [Char] -> IO Socket
connectToFile [Char]
path =
  IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Socket) -> IO Socket
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
    (Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
AF_UNIX SocketType
Stream ProtocolNumber
0)
    Socket -> IO ()
close
    (\Socket
sock -> do
      Socket -> SockAddr -> IO ()
S.connect Socket
sock ([Char] -> SockAddr
SockAddrUnix [Char]
path)
      Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock
    )

listenOnFile :: FilePath -> IO Socket
listenOnFile :: [Char] -> IO Socket
listenOnFile [Char]
path =
  IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Socket) -> IO Socket
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
    (Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
AF_UNIX SocketType
Stream ProtocolNumber
0)
    Socket -> IO ()
close
    (\Socket
sock -> do
        Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
sock SocketOption
ReuseAddr Int
1
        Socket -> SockAddr -> IO ()
S.bind Socket
sock ([Char] -> SockAddr
SockAddrUnix [Char]
path)
        Socket -> Int -> IO ()
S.listen Socket
sock Int
maxListenQueue
        Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock
    )

listenOn :: Maybe HostName -> Maybe ServiceName -> IO Socket
listenOn :: Maybe [Char] -> Maybe [Char] -> IO Socket
listenOn Maybe [Char]
host Maybe [Char]
serv = do
  -- We should probably specify addrFamily = AF_INET6 and the filter
  -- code below should be removed. AI_ADDRCONFIG is probably not
  -- necessary. But this code is well-tested. So, let's keep it.
  let hints :: AddrInfo
hints = AddrInfo
defaultHints { addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_ADDRCONFIG, AddrInfoFlag
AI_PASSIVE]
                           , addrSocketType :: SocketType
addrSocketType = SocketType
Stream
                           }
  [AddrInfo]
addrs <- Maybe AddrInfo -> Maybe [Char] -> Maybe [Char] -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) Maybe [Char]
host Maybe [Char]
serv
  -- Choose an IPv6 socket if exists.  This ensures the socket can
  -- handle both IPv4 and IPv6 if v6only is false.
  let addrs' :: [AddrInfo]
addrs' = (AddrInfo -> Bool) -> [AddrInfo] -> [AddrInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter (\AddrInfo
x -> AddrInfo -> Family
addrFamily AddrInfo
x Family -> Family -> Bool
forall a. Eq a => a -> a -> Bool
== Family
AF_INET6) [AddrInfo]
addrs
      addr :: AddrInfo
addr = if [AddrInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AddrInfo]
addrs' then [AddrInfo] -> AddrInfo
forall a. [a] -> a
head [AddrInfo]
addrs else [AddrInfo] -> AddrInfo
forall a. [a] -> a
head [AddrInfo]
addrs'
  IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Socket) -> IO Socket
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
      (Family -> SocketType -> ProtocolNumber -> IO Socket
socket (AddrInfo -> Family
addrFamily AddrInfo
addr) (AddrInfo -> SocketType
addrSocketType AddrInfo
addr) (AddrInfo -> ProtocolNumber
addrProtocol AddrInfo
addr))
      Socket -> IO ()
close
      (\Socket
sock -> do
          Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
sock SocketOption
ReuseAddr Int
1
          Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
sock SocketOption
NoDelay   Int
1
          Socket -> SockAddr -> IO ()
S.bind Socket
sock (AddrInfo -> SockAddr
addrAddress AddrInfo
addr)
          Socket -> Int -> IO ()
S.listen Socket
sock Int
maxListenQueue
          Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock
      )

listen :: String -> IO Socket
listen :: [Char] -> IO Socket
listen [Char]
port =
  if [Char]
"tcp" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
port then
    Maybe [Char] -> Maybe [Char] -> IO Socket
listenOn ([Char] -> Maybe [Char]
getHost [Char]
port) ([Char] -> Maybe [Char]
getService [Char]
port)
  else do
    let sockFile :: [Char]
sockFile = [Char] -> [Char]
dropS [Char]
port
    Bool
exists <- [Char] -> IO Bool
doesFileExist [Char]
sockFile
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Either IOException Socket
e <- IO Socket -> IO (Either IOException Socket)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
tryIO (IO Socket -> IO (Either IOException Socket))
-> IO Socket -> IO (Either IOException Socket)
forall a b. (a -> b) -> a -> b
$ [Char] -> IO Socket
connectToFile [Char]
sockFile
      case Either IOException Socket
e of
        Left IOException
_ -> [Char] -> IO ()
removeFile [Char]
sockFile
        Right Socket
_ -> do
          [Char] -> IO ()
putStrLn [Char]
"periodicd: bind: resource busy (Address already in use)"
          IO ()
forall a. IO a
exitFailure
    [Char] -> IO Socket
listenOnFile [Char]
sockFile

connect :: String -> IO Socket
connect :: [Char] -> IO Socket
connect [Char]
h | [Char]
"tcp" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
h = Maybe [Char] -> Maybe [Char] -> IO Socket
connectTo ([Char] -> Maybe [Char]
getHost [Char]
h) ([Char] -> Maybe [Char]
getService [Char]
h)
          | Bool
otherwise            = [Char] -> IO Socket
connectToFile ([Char] -> [Char]
dropS [Char]
h)

getDatagramAddrList :: String -> IO [AddrInfo]
getDatagramAddrList :: [Char] -> IO [AddrInfo]
getDatagramAddrList [Char]
hostPort = Maybe AddrInfo -> Maybe [Char] -> Maybe [Char] -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) Maybe [Char]
host Maybe [Char]
port
  where hints :: AddrInfo
hints = AddrInfo
defaultHints
          { addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_PASSIVE]
          , addrSocketType :: SocketType
addrSocketType = SocketType
Datagram
          }

        host :: Maybe [Char]
host = [Char] -> Maybe [Char]
getHost [Char]
hostPort
        port :: Maybe [Char]
port = [Char] -> Maybe [Char]
getService [Char]
hostPort

getDatagramAddr :: String -> IO (Maybe AddrInfo)
getDatagramAddr :: [Char] -> IO (Maybe AddrInfo)
getDatagramAddr [Char]
hostPort = [AddrInfo] -> Maybe AddrInfo
forall a. [a] -> Maybe a
listToMaybe ([AddrInfo] -> Maybe AddrInfo)
-> IO [AddrInfo] -> IO (Maybe AddrInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [AddrInfo]
getDatagramAddrList [Char]
hostPort

bindTo :: String -> IO Socket
bindTo :: [Char] -> IO Socket
bindTo [Char]
hostPort = do
  [AddrInfo]
addrs <- [Char] -> IO [AddrInfo]
getDatagramAddrList [Char]
hostPort
  [IO Socket] -> IO Socket
forall a. [IO a] -> IO a
firstSuccessful ([IO Socket] -> IO Socket) -> [IO Socket] -> IO Socket
forall a b. (a -> b) -> a -> b
$ (AddrInfo -> IO Socket) -> [AddrInfo] -> [IO Socket]
forall a b. (a -> b) -> [a] -> [b]
map AddrInfo -> IO Socket
tryToConnect [AddrInfo]
addrs
  where
  tryToConnect :: AddrInfo -> IO Socket
tryToConnect AddrInfo
addr =
    IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Socket) -> IO Socket
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
        (Family -> SocketType -> ProtocolNumber -> IO Socket
socket (AddrInfo -> Family
addrFamily AddrInfo
addr) (AddrInfo -> SocketType
addrSocketType AddrInfo
addr) (AddrInfo -> ProtocolNumber
addrProtocol AddrInfo
addr))
        Socket -> IO ()
close  -- only done if there's an error
        (\Socket
sock -> do
          Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
sock SocketOption
ReuseAddr Int
1
          Socket -> SockAddr -> IO ()
S.bind Socket
sock (SockAddr -> IO ()) -> SockAddr -> IO ()
forall a b. (a -> b) -> a -> b
$ AddrInfo -> SockAddr
addrAddress AddrInfo
addr
          Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock
        )


-- ipv6 fe80::1046:372a:8c3b:94b8%en0:80

countColon :: String -> Int
countColon :: [Char] -> Int
countColon = [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Char] -> Int) -> ([Char] -> [Char]) -> [Char] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
':')

-- ipv6 fe80::1046:372a:8c3b:94b8%en0:80
-- ipv6 fe80::1046:372a:8c3b:94b8%en0
-- ipv4 127.0.0.1:80
-- ipv4 127.0.0.1
-- only port :80
splitHostPort :: String -> (Maybe String, Maybe String)
splitHostPort :: [Char] -> (Maybe [Char], Maybe [Char])
splitHostPort [Char]
hostPort
  | Int
colon Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
hostPort, Maybe [Char]
forall a. Maybe a
Nothing)
  | Int
colon Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = (([Char] -> [Char]) -> [Char] -> Maybe [Char]
takeFst [Char] -> [Char]
forall a. a -> a
id [Char]
hostPort, ([Char] -> [Char]) -> [Char] -> Maybe [Char]
takeSnd [Char] -> [Char]
forall a. a -> a
id [Char]
hostPort)
  | Int
colon Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5 = ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
hostPort, Maybe [Char]
forall a. Maybe a
Nothing)
  | Int
colon Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
6 = (([Char] -> [Char]) -> [Char] -> Maybe [Char]
takeSnd [Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
hostPort, ([Char] -> [Char]) -> [Char] -> Maybe [Char]
takeFst [Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
hostPort )
  | Bool
otherwise = (Maybe [Char]
forall a. Maybe a
Nothing, Maybe [Char]
forall a. Maybe a
Nothing)
  where colon :: Int
colon = [Char] -> Int
countColon [Char]
hostPort
        takeFst :: ([Char] -> [Char]) -> [Char] -> Maybe [Char]
takeFst [Char] -> [Char]
f = [Char] -> Maybe [Char]
toMaybe ([Char] -> Maybe [Char])
-> ([Char] -> [Char]) -> [Char] -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
f ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
':') ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
f
        takeSnd :: ([Char] -> [Char]) -> [Char] -> Maybe [Char]
takeSnd [Char] -> [Char]
f = [Char] -> Maybe [Char]
toMaybe ([Char] -> Maybe [Char])
-> ([Char] -> [Char]) -> [Char] -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
f ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
1 ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
':') ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
f

dropS :: String -> String
dropS :: [Char] -> [Char]
dropS = Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
3 ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':')

toMaybe :: String -> Maybe String
toMaybe :: [Char] -> Maybe [Char]
toMaybe [] = Maybe [Char]
forall a. Maybe a
Nothing
toMaybe [Char]
xs = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
xs

getHost :: String -> Maybe String
getHost :: [Char] -> Maybe [Char]
getHost = (Maybe [Char], Maybe [Char]) -> Maybe [Char]
forall a b. (a, b) -> a
fst ((Maybe [Char], Maybe [Char]) -> Maybe [Char])
-> ([Char] -> (Maybe [Char], Maybe [Char]))
-> [Char]
-> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> (Maybe [Char], Maybe [Char])
splitHostPort ([Char] -> (Maybe [Char], Maybe [Char]))
-> ([Char] -> [Char]) -> [Char] -> (Maybe [Char], Maybe [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
dropS

getService :: String -> Maybe String
getService :: [Char] -> Maybe [Char]
getService = (Maybe [Char], Maybe [Char]) -> Maybe [Char]
forall a b. (a, b) -> b
snd ((Maybe [Char], Maybe [Char]) -> Maybe [Char])
-> ([Char] -> (Maybe [Char], Maybe [Char]))
-> [Char]
-> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> (Maybe [Char], Maybe [Char])
splitHostPort ([Char] -> (Maybe [Char], Maybe [Char]))
-> ([Char] -> [Char]) -> [Char] -> (Maybe [Char], Maybe [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
dropS