diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2021 Owens Murray, LLC. + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,8 @@ +# om-doh + +This haskell package provides a DoH (DNS over HTTPs) implementation, +exposed as a Servant API and implementation, so you can run it directly +using Warp or embed it as part of a larger service, either directly as +a servant api fragment or by converting it to a WAI Application. + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/om-doh.cabal b/om-doh.cabal new file mode 100644 --- /dev/null +++ b/om-doh.cabal @@ -0,0 +1,41 @@ +-- Initial om-doh.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: om-doh +version: 0.1.0.0 +synopsis: om-doh +-- description: +homepage: https://github.com/owensmurray/om-doh +license: MIT +license-file: LICENSE +author: Rick Owens +maintainer: rick@owensmurray.com +copyright: 2021 Owens Murray, LLC. +-- category: +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + exposed-modules: + OM.DoH.Api + OM.DoH.Server + other-modules: + -- other-extensions: + build-depends: + base >= 4.13 && < 4.14, + base64 >= 0.4.2.2 && < 0.5, + bytestring >= 0.10.10.1 && < 0.11, + http-api-data >= 0.4.1.1 && < 0.5, + resolv >= 0.1.2.0 && < 0.2, + servant >= 0.16.2 && < 0.17, + servant-server >= 0.16.2 && < 0.17, + text >= 1.2.4.0 && < 1.3 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: + -Wmissing-deriving-strategies + -Wmissing-export-lists + -Wmissing-import-lists + -Wredundant-constraints + diff --git a/src/OM/DoH/Api.hs b/src/OM/DoH/Api.hs new file mode 100644 --- /dev/null +++ b/src/OM/DoH/Api.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +{- | Description: Servant spec describing the DoH Api. -} +module OM.DoH.Api ( + DoHApi(..), + Query(..), + Response(..), + DnsMsgCT, +) where + + +import Data.ByteString (ByteString) +import Data.ByteString.Base64 (decodeBase64) +import Data.Text.Encoding (encodeUtf8) +import GHC.Generics (Generic) +import Servant.API (type (:>), Accept(contentType), + MimeRender(mimeRender), MimeUnrender(mimeUnrender), Get, Post, + QueryParam', ReqBody, Required, Strict, Summary) +import Servant.API.Generic (GenericMode((:-))) +import Web.HttpApiData (FromHttpApiData(parseUrlPiece)) +import qualified Data.ByteString.Lazy as BSL + + +{- | The DoH api, defined in the "Servant.API.Generic" style. -} +data DoHApi route = DoHApi { + getQuery :: route :- + Summary "Submit a raw DNS query on the query string." + :> QueryParam' '[Required, Strict] "dns" Query + :> Get '[DnsMsgCT] Response, + postQuery :: route :- + Summary "Submit a raw DNS query in the POST body." + :> ReqBody '[DnsMsgCT] Query + :> Post '[DnsMsgCT] Response + } + deriving stock (Generic) + + +{- | + A raw DNS query message. The "Network.DNS" module contains tools for + encoding and decoding these messages. +-} +newtype Query = Query {unQuery :: ByteString} + deriving newtype (MimeUnrender DnsMsgCT) +instance FromHttpApiData Query where + parseUrlPiece txt = Query <$> decodeBase64 (encodeUtf8 txt) + + +{- | + A raw DNS response message. The 'Network.DNS' module contains tools + for encoding and decoding these messages. +-} +newtype Response = Response {unResponse :: ByteString} + deriving newtype (MimeRender DnsMsgCT) + + +{- | The @application/dns-message@ content type. -} +data DnsMsgCT +instance Accept DnsMsgCT where + contentType _proxy = "application/dns-message" +instance MimeRender DnsMsgCT ByteString where + mimeRender _proxy msg = BSL.fromStrict msg +instance MimeUnrender DnsMsgCT ByteString where + mimeUnrender _proxy = Right . BSL.toStrict + + diff --git a/src/OM/DoH/Server.hs b/src/OM/DoH/Server.hs new file mode 100644 --- /dev/null +++ b/src/OM/DoH/Server.hs @@ -0,0 +1,26 @@ + +{- | Description: DohApi implementation. -} +module OM.DoH.Server ( + server, +) where + + +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Network.DNS (sendRaw) +import OM.DoH.Api (DoHApi(DoHApi, getQuery, postQuery), Query(unQuery), + Response(Response)) +import Servant.Server.Generic (AsServerT) + + +{- | + An implementation of the DoH api that delegates to the local machine's + DNS resolver, using the @resolv@ package (see "Network.DNS"). +-} +server :: (MonadIO m) => DoHApi (AsServerT m) +server = DoHApi { + getQuery = liftIO . fmap Response . sendRaw . unQuery, + postQuery = liftIO . fmap Response . sendRaw . unQuery + } + + +