commit 3441ab2bbb78bb3367411f50c67d27ce0dfc901b Author: Mats Rauhala Date: Mon Sep 24 23:36:26 2018 +0300 Initial commit diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..7a7dc09 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +result +dist/ diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..cef1c57 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for rauhala-api + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..00aedcc --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018, Mats Rauhala + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Mats Rauhala nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..99ce25c --- /dev/null +++ b/default.nix @@ -0,0 +1,3 @@ +{ haskellPackages, haskell }: + +haskellPackages.callCabal2nix "rauhala-api" ./. {} diff --git a/executables/api.hs b/executables/api.hs new file mode 100644 index 0000000..611317e --- /dev/null +++ b/executables/api.hs @@ -0,0 +1,8 @@ +module Main where + +import Server +import Network.Wai.Handler.Warp +import Network.Wai.Middleware.Cors (simpleCors) + +main :: IO () +main = run 8081 (simpleCors application) diff --git a/executables/generator.hs b/executables/generator.hs new file mode 100644 index 0000000..6d21882 --- /dev/null +++ b/executables/generator.hs @@ -0,0 +1,11 @@ +{-# Language TypeApplications #-} +{-# Language NoImplicitPrelude #-} +module Main where + +import API +import Servant.JS +import Data.Proxy (Proxy(..)) +import ClassyPrelude + +main :: IO () +main = putStrLn $ jsForAPI (Proxy @API) vanillaJS diff --git a/rauhala-api.cabal b/rauhala-api.cabal new file mode 100644 index 0000000..de0eab9 --- /dev/null +++ b/rauhala-api.cabal @@ -0,0 +1,66 @@ +-- Initial rauhala-api.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: rauhala-api +version: 0.1.0.0 +-- synopsis: +-- description: +license: BSD3 +license-file: LICENSE +author: Mats Rauhala +maintainer: mats@rauhala.info +-- copyright: +category: Web +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 + +library + exposed-modules: API + , API.IPFS + , Server + , Server.IPFS + -- other-modules: + -- other-extensions: + build-depends: base >=4.10 + , servant + , servant-server + , servant-docs + , classy-prelude + , aeson + , pandoc + , http-media + , dns + , lens + hs-source-dirs: src + default-language: Haskell2010 + +executable rauhala-api + main-is: api.hs + -- other-modules: + -- other-extensions: + build-depends: base >=4.10 + , rauhala-api + , servant-server + , wai + , wai-cors + , warp + , mtl + , classy-prelude + , text + , wai + hs-source-dirs: executables + default-language: Haskell2010 + +executable generator + main-is: generator.hs + -- other-modules: + -- other-extensions: + build-depends: base >=4.10 + , rauhala-api + , servant-js + , mtl + , classy-prelude + , text + hs-source-dirs: executables + default-language: Haskell2010 diff --git a/release.nix b/release.nix new file mode 100644 index 0000000..fe06a33 --- /dev/null +++ b/release.nix @@ -0,0 +1,28 @@ +{ pkgs ? import {} }: + +let + _pkgs = import (pkgs.fetchFromGitHub { + owner = "NixOS"; + repo = "nixpkgs"; + rev = "234a24cbeb66f70afaab9f13a5a9973c2fb956e0"; # LTS 12.10 + sha256 = "1n0n6dwyllkddl4nxjhkr1cq7mpk786dsr6v36589c7flj8inbwf"; + }) {}; + inherit (_pkgs) haskellPackages haskell buildEnv; + pkg = import ./default.nix { inherit haskellPackages haskell; }; + shell = buildEnv { + name = "shell"; + paths = []; + buildInputs = [ + _pkgs.binutils-unwrapped + haskellPackages.ghcid + haskellPackages.hasktags + (haskellPackages.ghcWithHoogle (_: pkg.buildInputs ++ pkg.propagatedBuildInputs)) + ]; + }; + +in + +{ + "rauhala-api" = pkg; + "shell" = shell; +} diff --git a/src/API.hs b/src/API.hs new file mode 100644 index 0000000..65e64d1 --- /dev/null +++ b/src/API.hs @@ -0,0 +1,35 @@ +{-# Language DataKinds #-} +{-# Language NoImplicitPrelude #-} +{-# Language TypeOperators #-} +{-# Language MultiParamTypeClasses #-} +{-# Language OverloadedStrings #-} +module API where + +import Servant.API +import ClassyPrelude + +import qualified API.IPFS as IPFS + +import Text.Pandoc.Readers.Markdown (readMarkdown) +import Text.Pandoc.Writers.HTML (writeHtml5String) +import Text.Pandoc.Class (runPure, PandocMonad) +import Text.Pandoc.Options (def) +import Network.HTTP.Media ((//), (/:)) + +data HTML + +newtype Docs = Docs Text + +instance MimeRender PlainText Docs where + mimeRender _ (Docs d) = fromStrict $ encodeUtf8 d + +instance MimeRender HTML Docs where + mimeRender _ (Docs d) = either (encodeUtf8 . pack . show) (fromStrict . encodeUtf8) $ runPure (writeHtml5String def <=< readMarkdown def $ d) + +instance Accept HTML where + contentType _ = "text" // "html" /: ("charset", "utf-8") + +type API = "ipfs" :> IPFS.API + +type DocumentedAPI = API + :<|> "help" :> Get '[PlainText, HTML] Docs diff --git a/src/API/IPFS.hs b/src/API/IPFS.hs new file mode 100644 index 0000000..cdbe329 --- /dev/null +++ b/src/API/IPFS.hs @@ -0,0 +1,24 @@ +{-# Language DataKinds #-} +{-# Language TypeOperators #-} +{-# Language GeneralizedNewtypeDeriving #-} +{-# Language MultiParamTypeClasses #-} +{-# Language NoImplicitPrelude #-} +{-# Language DeriveGeneric #-} +{-# Language OverloadedStrings #-} +module API.IPFS where + +import ClassyPrelude +import Servant.API +import Data.Aeson +import Servant.Docs (singleSample, ToSample(..)) + +newtype VersionHash = VersionHash Text + deriving (Show, ToJSON) + +instance ToSample VersionHash where + toSamples _ = singleSample (VersionHash "QmQdyH1o6g7Q1p4rJCWABTup5KgxYK1T9AZxBWpnhgMQQQ") + +instance MimeRender PlainText VersionHash where + mimeRender _ (VersionHash h) = fromStrict . encodeUtf8 $ h + +type API = "current" :> Get '[JSON, PlainText] VersionHash diff --git a/src/Server.hs b/src/Server.hs new file mode 100644 index 0000000..20a168f --- /dev/null +++ b/src/Server.hs @@ -0,0 +1,21 @@ +{-# Language NoImplicitPrelude #-} +{-# Language TypeApplications #-} +{-# Language OverloadedStrings #-} +{-# Language GeneralizedNewtypeDeriving #-} +module Server where + +import API +import ClassyPrelude +import Servant +import qualified Servant.Docs as Docs + +import qualified Server.IPFS as IPFS + + +server :: Server DocumentedAPI +server = IPFS.handler :<|> pure mkDocs + where + mkDocs = Docs $ pack $ Docs.markdown $ Docs.docs (Proxy @API) + +application :: Application +application = serve (Proxy @DocumentedAPI) server diff --git a/src/Server/IPFS.hs b/src/Server/IPFS.hs new file mode 100644 index 0000000..a96711b --- /dev/null +++ b/src/Server/IPFS.hs @@ -0,0 +1,28 @@ +{-# Language NoImplicitPrelude #-} +{-# Language OverloadedStrings #-} +{-# Language ViewPatterns #-} +{-# Language FlexibleContexts #-} +module Server.IPFS where + +import API.IPFS +import Servant +import ClassyPrelude + +import Network.DNS + +import Control.Lens (over, _Left) + +handler :: Server API +handler = liftIO getHash >>= either (const (throwError err500)) return + where + getHash :: IO (Either String VersionHash) + getHash = + makeResolvSeed defaultResolvConf >>= + \rs -> withResolver rs $ \resolver -> do + eTxt <- over _Left show <$> lookupTXT resolver "rauhala.info" + -- This is terrible + return (eTxt >>= maybe (Left "Could not find dnslink") Right . hash) + hash [x] = case x of + (stripPrefix "dnslink" -> Just h) -> Just . VersionHash . decodeUtf8 $ h + _ -> Nothing + hash _ = Nothing