Verified Commit 7f85bbf7 authored by Allele Dev's avatar Allele Dev

init

parents
# haskell
.cabal-sandbox
.hsenv
.stack-work
cabal-project.local
cabal.sandbox.config
dist
dist-newstyle
stack.yaml
# emacs
TAGS
tags
codex.tags
\#*
.\#*
# Contributor Covenant Code of Conduct
## Our Pledge
In the interest of fostering an open and welcoming environment, we as
contributors and maintainers pledge to making participation in our project and
our community a harassment-free experience for everyone, regardless of age, body
size, disability, ethnicity, gender identity and expression, level of experience,
nationality, personal appearance, race, religion, or sexual identity and
orientation.
## Our Standards
Examples of behavior that contributes to creating a positive environment
include:
* Using welcoming and inclusive language
* Being respectful of differing viewpoints and experiences
* Gracefully accepting constructive criticism
* Focusing on what is best for the community
* Showing empathy towards other community members
Examples of unacceptable behavior by participants include:
* The use of sexualized language or imagery and unwelcome sexual attention or
advances
* Trolling, insulting/derogatory comments, and personal or political attacks
* Public or private harassment
* Publishing others' private information, such as a physical or electronic
address, without explicit permission
* Other conduct which could reasonably be considered inappropriate in a
professional setting
## Our Responsibilities
Project maintainers are responsible for clarifying the standards of acceptable
behavior and are expected to take appropriate and fair corrective action in
response to any instances of unacceptable behavior.
Project maintainers have the right and responsibility to remove, edit, or
reject comments, commits, code, wiki edits, issues, and other contributions
that are not aligned to this Code of Conduct, or to ban temporarily or
permanently any contributor for other behaviors that they deem inappropriate,
threatening, offensive, or harmful.
## Scope
This Code of Conduct applies both within project spaces and in public spaces
when an individual is representing the project or its community. Examples of
representing a project or community include using an official project e-mail
address, posting via an official social media account, or acting as an appointed
representative at an online or offline event. Representation of a project may be
further defined and clarified by project maintainers.
## Enforcement
Instances of abusive, harassing, or otherwise unacceptable behavior
may be reported by contacting the project team at
[email protected] All
complaints will be reviewed and investigated and will result in a
response that is deemed necessary and appropriate to the
circumstances. The project team is obligated to maintain
confidentiality with regard to the reporter of an incident. Further
details of specific enforcement policies may be posted separately.
Project maintainers who do not follow or enforce the Code of Conduct in good
faith may face temporary or permanent repercussions as determined by other
members of the project's leadership.
## Attribution
This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 1.4,
available at [http://contributor-covenant.org/version/1/4][version]
[homepage]: http://contributor-covenant.org
[version]: http://contributor-covenant.org/version/1/4/
This diff is collapsed.
# linear-socket
| linear-socket | 0.2.0.0 |
| ------------- | --------------------------------- |
| Maintainer | Allele Dev ([email protected]) |
| Funding | $0 USD |
| Copyright | Copyright (C) 2017 Allele Dev |
| License | GPL-3 |
## Features
## Examples
## Contributing
Contributions are welcome! Documentation, examples, code, and
feedback - they all help.
Be sure to review the included code of conduct. This project adheres
to the [Contributor's Covenant](http://contributor-covenant.org/). By
participating in this project you agree to abide by its terms.
This project currently has no funding, so it is maintained strictly on
the basis of its use to me. No guarantees are made about attention to
issues or contributions, or timeliness thereof.
## Developer Setup
The easiest way to start contributing is to install
[stack](https://github.com/commercialhaskell/stack). stack can install
GHC/Haskell for you, and automates common developer tasks.
The key commands are:
* `stack setup`: install GHC
* `stack build`: build the project
* `stack clean`: clean build artifacts
* `stack haddock`: builds documentation
* `stack test`: run all tests
* `stack bench`: run all benchmarks
* `stack ghci`: start a REPL instance
## Licensing
This project is distributed under the GPL-3 license. See the included
[LICENSE](./LICENSE) file for more details.
import Distribution.Simple
main = defaultMain
packages: .
# 0.1.0.0 (March 29, 2017)
-- This file has been generated from package.yaml by hpack version 0.17.1.
--
-- see: https://github.com/sol/hpack
name: linear-socket
version: 0.2.0.0
synopsis: Initial project template from stack
description: Please see README.md
license: GPL-3
license-file: LICENSE
author: Allele Dev
maintainer: [email protected]
copyright: Copyright (C) 2017 Allele Dev
category: Web
build-type: Simple
cabal-version: >= 1.10
extra-source-files:
changelog.md
CODE_OF_CONDUCT.md
README.md
source-repository head
type: git
location: https://gitlab.com/queertypes/linear-socket
library
hs-source-dirs:
src
build-depends:
base >=4.7 && <5
, ynot-prelude
, network
, bytestring
exposed-modules:
Network.Typed.Socket
ghc-options: -Wall
default-extensions: NoImplicitPrelude BinaryLiterals LambdaCase TupleSections NegativeLiterals OverloadedStrings ApplicativeDo Arrows BangPatterns MagicHash UnboxedTuples DeriveFoldable DeriveFunctor DeriveTraversable GeneralizedNewtypeDeriving StandaloneDeriving DisambiguateRecordFields DuplicateRecordFields NamedFieldPuns NamedWildCards RecordWildCards OverloadedLabels FlexibleInstances FunctionalDependencies MultiParamTypeClasses ConstraintKinds DataKinds EmptyCase EmptyDataDecls GADTs KindSignatures PartialTypeSignatures RankNTypes RoleAnnotations ScopedTypeVariables TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators TypeSynonymInstances
default-language: Haskell2010
executable linear-socket-hlint
main-is: HLint.hs
ghc-options: -w -threaded -rtsopts -with-rtsopts=-N
hs-source-dirs:
test
default-extensions: NoImplicitPrelude BinaryLiterals LambdaCase TupleSections NegativeLiterals OverloadedStrings ApplicativeDo Arrows BangPatterns MagicHash UnboxedTuples DeriveFoldable DeriveFunctor DeriveTraversable GeneralizedNewtypeDeriving StandaloneDeriving DisambiguateRecordFields DuplicateRecordFields NamedFieldPuns NamedWildCards RecordWildCards OverloadedLabels FlexibleInstances FunctionalDependencies MultiParamTypeClasses ConstraintKinds DataKinds EmptyCase EmptyDataDecls GADTs KindSignatures PartialTypeSignatures RankNTypes RoleAnnotations ScopedTypeVariables TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators TypeSynonymInstances
build-depends:
base
, ynot-prelude
, hlint >=1.9.27
other-modules:
Spec
default-language: Haskell2010
test-suite linear-socket-test
type: exitcode-stdio-1.0
hs-source-dirs:
test
main-is: Spec.hs
build-depends:
base
, ynot-prelude
, network
, linear-socket
, tasty-hspec
, hspec
other-modules:
HLint
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
default-extensions: NoImplicitPrelude BinaryLiterals LambdaCase TupleSections NegativeLiterals OverloadedStrings ApplicativeDo Arrows BangPatterns MagicHash UnboxedTuples DeriveFoldable DeriveFunctor DeriveTraversable GeneralizedNewtypeDeriving StandaloneDeriving DisambiguateRecordFields DuplicateRecordFields NamedFieldPuns NamedWildCards RecordWildCards OverloadedLabels FlexibleInstances FunctionalDependencies MultiParamTypeClasses ConstraintKinds DataKinds EmptyCase EmptyDataDecls GADTs KindSignatures PartialTypeSignatures RankNTypes RoleAnnotations ScopedTypeVariables TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators TypeSynonymInstances
default-language: Haskell2010
name: linear-socket
version: '0.2.0.0'
synopsis: Initial project template from stack
description: Please see README.md
category: Web
author: Allele Dev
maintainer: [email protected]
copyright: Copyright (C) 2017 Allele Dev
license: GPL-3
git: https://gitlab.com/queertypes/linear-socket
default-extensions:
- NoImplicitPrelude
- BinaryLiterals
- LambdaCase
- TupleSections
- NegativeLiterals
- OverloadedStrings
- ApplicativeDo
- Arrows
- BangPatterns
- MagicHash
- UnboxedTuples
- DeriveFoldable
- DeriveFunctor
- DeriveTraversable
- GeneralizedNewtypeDeriving
- StandaloneDeriving
- DisambiguateRecordFields
- DuplicateRecordFields
- NamedFieldPuns
- NamedWildCards
- RecordWildCards
- OverloadedLabels
- FlexibleInstances
- FunctionalDependencies
- MultiParamTypeClasses
- ConstraintKinds
- DataKinds
- EmptyCase
- EmptyDataDecls
- GADTs
- KindSignatures
- PartialTypeSignatures
- RankNTypes
- RoleAnnotations
- ScopedTypeVariables
- TypeApplications
- TypeFamilies
- TypeFamilyDependencies
- TypeOperators
- TypeSynonymInstances
extra-source-files:
- README.md
- changelog.md
- CODE_OF_CONDUCT.md
library:
source-dirs: src
ghc-options: -Wall
exposed-modules:
dependencies:
- base >=4.7 && <5
- ynot-prelude
- network
- bytestring
executables:
linear-socket-hlint:
main: HLint.hs
source-dirs: test
ghc-options:
- -w
- -threaded
- -rtsopts
- -with-rtsopts=-N
default-extensions: []
dependencies:
- base
- ynot-prelude
- hlint >=1.9.27
tests:
linear-socket-test:
main: Spec.hs
source-dirs: test
ghc-options:
- -Wall
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- base
- ynot-prelude
- network
- linear-socket
- tasty-hspec
- hspec
{-# LANGUAGE TypeFamilyDependencies #-}
{-# OPTIONS_GHC -Wall #-}
module Network.Typed.Socket (
SSocket,
SocketFamily(..),
SocketProtocol(..),
SockAddr(..),
SocketStatus(..),
socket,
connect,
bind,
accept,
listen,
send,
sendTo,
recv,
recvFrom,
close,
shutdownSend,
shutdownReceive,
shutdownBoth,
withSocket,
withTcp4Socket,
withTcp6Socket,
withTcpUnixSocket,
withUdp4Socket,
withUdp6Socket,
withUdpUnixSocket,
setSocketOption,
makePortReusable,
makeAddrReusable
) where
import Prelude (Bool(..), IO, Char, Int)
import Data.ByteString (ByteString)
import YNotPrelude (error)
import Control.Applicative
import Control.Exception (bracket)
import Control.Monad
import qualified Network.Socket as NS
import qualified Network.Socket.ByteString as NSB
-- Socket family singletons
data SocketFamily
= Unix
| InetV4
| InetV6
data SocketProtocol
= Tcp -- Stream
| Udp -- Datagram
data SocketStatus
= Unconnected
| Bound
| Listening
| Connected
| Closed
data ShutdownStatus
= Available
| CannotReceive
| CannotSend
| CannotSendOrReceive
newtype
SSocket (f :: SocketFamily) (p :: SocketProtocol)
(s :: SocketStatus) (sh :: ShutdownStatus)
= SSocket NS.Socket
data SockAddr (f :: SocketFamily) where
SockAddrInet ::
!NS.PortNumber -> !NS.HostAddress -> SockAddr 'InetV4
SockAddrInet6 ::
NS.PortNumber -> !NS.FlowInfo -> !NS.HostAddress6 -> !NS.ScopeID -> SockAddr 'InetV6
SockAddrUnix :: ![Char] -> SockAddr 'Unix
socket :: forall f p sh.
(SockFam f, SockProto p) => IO (SSocket f p 'Unconnected sh)
socket =
let x = socketFamily (socketFamily1 :: SocketFamily1 f)
y = socketProtocol (sockProto1 :: SocketProtocol1 p)
in SSocket <$> (NS.socket x y NS.defaultProtocol)
close :: Closeable s ~ 'True =>
SSocket f p s sh -> IO (SSocket f p 'Closed sh)
close (SSocket s) = NS.close s >> return (SSocket s)
connect ::
SSocket f 'Tcp 'Unconnected sh -> SockAddr f
-> IO (SSocket f 'Tcp 'Connected 'Available)
connect (SSocket s) addr =
NS.connect s (toNetworkSockAddr addr) >> return (SSocket s)
bind :: SSocket f p 'Unconnected sh -> SockAddr f -> IO (SSocket f p 'Bound sh)
bind (SSocket s) addr =
NS.bind s (toNetworkSockAddr addr) >> return (SSocket s)
listen :: SSocket f 'Tcp 'Bound sh -> Int -> IO (SSocket f 'Tcp 'Listening sh)
listen (SSocket s) n = NS.listen s n >> return (SSocket s)
accept :: SSocket f 'Tcp 'Listening sh -> IO (SSocket f 'Tcp 'Connected sh, NS.SockAddr)
accept (SSocket s) = do
(s', a) <- NS.accept s
return (SSocket s', a)
send :: SSocket f 'Tcp 'Connected sh -> ByteString -> IO Int
send (SSocket s) bs = NSB.send s bs
recv :: SSocket f 'Tcp 'Connected sh -> Int -> IO ByteString
recv (SSocket s) n = NSB.recv s n
shutdownReceive ::
CanShutdownReceive sh ~ 'True =>
SSocket f p s sh
-> IO (SSocket f p s (Shutdown sh 'NS.ShutdownReceive))
shutdownReceive (SSocket s) =
NS.shutdown s NS.ShutdownReceive >> return (SSocket s)
shutdownSend ::
CanShutdownSend sh ~ 'True =>
SSocket f p s sh
-> IO (SSocket f p s (Shutdown sh 'NS.ShutdownSend))
shutdownSend (SSocket s) =
NS.shutdown s NS.ShutdownSend >> return (SSocket s)
shutdownBoth ::
CanShutdownBoth sh ~ 'True =>
SSocket f p s sh
-> IO (SSocket f p s (Shutdown sh 'NS.ShutdownBoth))
shutdownBoth (SSocket s) =
NS.shutdown s NS.ShutdownBoth >> return (SSocket s)
-- simplified assumptions: require connectionless UDP for sendTo/recvFrom
sendTo :: SSocket f 'Udp 'Unconnected sh -> ByteString -> SockAddr f -> IO Int
sendTo (SSocket s) bs addr =
NSB.sendTo s bs (toNetworkSockAddr addr)
recvFrom ::
SockFam f => SSocket f 'Udp 'Unconnected sh -> Int -> IO (ByteString, SockAddr f)
recvFrom (SSocket s) n = do
(bs, sa) <- NSB.recvFrom s n
return (bs, fromNetworkSockAddr sa)
-- bracketed, typed helpers
withSocket :: (SockFam f, SockProto p) => (SSocket f p 'Unconnected sh -> IO a) -> IO a
withSocket = bracket socket close
withTcp4Socket :: (SSocket 'InetV4 'Tcp 'Unconnected sh -> IO a) -> IO a
withTcp4Socket = withSocket
withTcp6Socket :: (SSocket 'InetV6 'Tcp 'Unconnected sh -> IO a) -> IO a
withTcp6Socket = withSocket
withTcpUnixSocket :: (SSocket 'Unix 'Tcp 'Unconnected sh -> IO a) -> IO a
withTcpUnixSocket = withSocket
withUdp4Socket :: (SSocket 'InetV4 'Udp 'Unconnected sh -> IO a) -> IO a
withUdp4Socket = withSocket
withUdp6Socket :: (SSocket 'InetV6 'Udp 'Unconnected sh -> IO a) -> IO a
withUdp6Socket = withSocket
withUdpUnixSocket :: (SSocket 'Unix 'Udp 'Unconnected sh -> IO a) -> IO a
withUdpUnixSocket = withSocket
setSocketOption :: SSocket f p s sh -> NS.SocketOption -> Int -> IO (SSocket f p s sh)
setSocketOption ss@(SSocket s) opt n = NS.setSocketOption s opt n >> return ss
makePortReusable :: SSocket f p s sh -> IO (SSocket f p s sh)
makePortReusable s = setSocketOption s NS.ReusePort 0 >> return s
makeAddrReusable :: SSocket f p s sh -> IO (SSocket f p s sh)
makeAddrReusable s = setSocketOption s NS.ReuseAddr 0 >> return s
--------------------------------------------------------------------------------
-- Type machinery to make the above possible
--------------------------------------------------------------------------------
-- GADT 1-1
data SocketFamily1 (f :: SocketFamily) where
SUnix :: SocketFamily1 'Unix
SInetV4 :: SocketFamily1 'InetV4
SInetV6 :: SocketFamily1 'InetV6
-- type-level -> term-level
class SockFam (f :: SocketFamily) where
socketFamily1 :: SocketFamily1 f
instance SockFam 'Unix where socketFamily1 = SUnix
instance SockFam 'InetV4 where socketFamily1 = SInetV4
instance SockFam 'InetV6 where socketFamily1 = SInetV6
-- term-level -> socket API
socketFamily :: SocketFamily1 f -> NS.Family
socketFamily = \case
SUnix -> NS.AF_UNIX
SInetV4 -> NS.AF_INET
SInetV6 -> NS.AF_INET6
data SocketProtocol1 (p :: SocketProtocol) where
STcp :: SocketProtocol1 'Tcp
SUdp :: SocketProtocol1 'Udp
class SockProto (p :: SocketProtocol) where
sockProto1 :: SocketProtocol1 p
instance SockProto 'Tcp where sockProto1 = STcp
instance SockProto 'Udp where sockProto1 = SUdp
socketProtocol :: SocketProtocol1 p -> NS.SocketType
socketProtocol = \case
STcp -> NS.Stream
SUdp -> NS.Datagram
type family Closeable (s :: SocketStatus) :: Bool where
Closeable 'Unconnected = 'True
Closeable 'Bound = 'True
Closeable 'Listening = 'True
Closeable 'Connected = 'True
Closeable 'Closed = 'False
toNetworkSockAddr :: SockAddr f -> NS.SockAddr
toNetworkSockAddr = \case
(SockAddrInet p addr) -> NS.SockAddrInet p addr
(SockAddrInet6 p f addr scope) -> NS.SockAddrInet6 p f addr scope
(SockAddrUnix s) -> NS.SockAddrUnix s
-- todo: needs a stronger proof
-- leverage (SocketFamily1 f) to guide type-refinement below, but
-- currently fails to establish an isomorphism between NS.SockAddr and
-- SockAddr f
fromNetworkSockAddr :: forall f. SockFam f => NS.SockAddr -> SockAddr f
fromNetworkSockAddr netAddr = case (netAddr, socketFamily1 :: SocketFamily1 f) of
(NS.SockAddrInet p addr, SInetV4) -> SockAddrInet p addr
(NS.SockAddrInet6 p f addr scope, SInetV6) -> SockAddrInet6 p f addr scope
(NS.SockAddrUnix s, SUnix) -> SockAddrUnix s
_ -> error "impossible"
-- transitions that make sense
type family Shutdown (sh :: ShutdownStatus) (cmd :: NS.ShutdownCmd)
:: ShutdownStatus where
Shutdown 'Available 'NS.ShutdownSend = 'CannotSend
Shutdown 'Available 'NS.ShutdownReceive = 'CannotReceive
Shutdown 'Available 'NS.ShutdownBoth = 'CannotSendOrReceive
Shutdown 'CannotSend 'NS.ShutdownReceive = 'CannotSendOrReceive
Shutdown 'CannotReceive 'NS.ShutdownSend = 'CannotSendOrReceive
type family CanShutdownReceive (sh :: ShutdownStatus) :: Bool where
CanShutdownReceive 'Available = 'True
CanShutdownReceive 'CannotSend = 'True
type family CanShutdownSend (sh :: ShutdownStatus) :: Bool where
CanShutdownSend 'Available = 'True
CanShutdownSend 'CannotReceive = 'True
type family CanShutdownBoth (sh :: ShutdownStatus) :: Bool where
CanShutdownBoth 'Available = 'True
-- not really used yet
-- it'd be nice to track these at the type-level and also extend the
-- interface so more socket options can be set, rather than just the
-- Int ones
{-
data SocketOption
= Debug
| ReuseAddr
| SType
| SoError
| DontRoute
| Broadcast
| SendBuffer
| RecvBuffer
| KeepAlive
| OOBInline
| TimeToLive
| MaxSegment
| NoDelay
| Cork
| Linger
| ReusePort
| RecvLowWater
| SendLowWater
| RecvTimeout
| SendTimeout
| UseLoopBack
| UserTimeout
| IPv6Only
-}
-----------------------------------------------------------------------------