diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,28 @@ +.DS_Store +.idea +*.log +tmp/ + +dist +dist-* +cabal-dev +*.o +*.hi +*.hie +*.chi +*.chs.h +*.dyn_o +*.dyn_hi +.hpc +.hsenv +.cabal-sandbox/ +cabal.sandbox.config +*.prof +*.aux +*.hp +*.eventlog +.stack-work/ +cabal.project.local +cabal.project.local~ +.HTF/ +.ghc.environment.* diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for bencoding-lens + +## 0.1.0.0 -- 2022-02-22 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2021-2022 Joseph Morag +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. + +2. 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. + +3. Neither the name of the copyright holder nor the names of its 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 HOLDER 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,46 @@ +# bencoding-lens + +Law abiding lenses and traversals for +[bencoding](https://hackage.haskell.org/package/bencoding), ported from +[lens-aeson](https://hackage.haskell.org/package/lens-aeson-1.1.1). Works with +arbitrary bencoded data, although most examples in the wild are torrent files. + + +``` haskell +{-# LANGUAGE OverloadedStrings #-} + +import Control.Lens +import Data.BEncode +import Data.BEncode.Lens + +import Network.HTTP.Simple -- from http-conduit +import Crypto.Hash -- from cryptonite + +main = do + -- Get the ubuntu 20.04 live server torrent file with http-conduit + torrent <- getResponseBody <$> httpBS "https://releases.ubuntu.com/20.04/ubuntu-20.04.4-live-server-amd64.iso.torrent" + -- Print some interesting bits of the torrent file + + -- Announce link + print (torrent ^? key "announce") + -- Just (BString "https://torrent.ubuntu.com/announce") + + -- Keys of the top level dict + print (fmap fst (torrent ^@.. members)) + -- ["announce","announce-list","comment","created by","creation date","info"] + + -- Keys of the info dict + print (fmap fst (torrent ^@.. key "info" . members)) + -- ["length","name","piece length","pieces"] + + -- Piece length + print (torrent ^? key "info" . key "piece length" . _BInteger) + -- Just 262144 + + -- Compute the info hash (see definition below) + print (torrent ^?! infoHash) + -- b44a0e20fa5b7cecb77156333b4268dfd7c30afb + +infoHash :: (AsBValue t) => Fold t (Digest SHA1) +infoHash = key "info" . to (hashlazy . encode) +``` diff --git a/bencoding-lens.cabal b/bencoding-lens.cabal new file mode 100644 --- /dev/null +++ b/bencoding-lens.cabal @@ -0,0 +1,58 @@ +cabal-version: >=1.10 +name: bencoding-lens +version: 0.1.0.0 +synopsis: Lenses for bencoded data. +description: A port of lens-aeson for bencoding. +homepage: https://github.com/jmorag/bencoding-lens +bug-reports: https://github.com/jmorag/bencoding-lens/issues +license: BSD3 +license-file: LICENSE +author: Joseph Morag +maintainer: Joseph Morag +copyright: (c) 2021-2022, Joseph Morag +category: Data +extra-source-files: + .gitignore + CHANGELOG.md + README.md + +build-type: Simple +tested-with: + GHC ==7.10.3 + || ==8.0.2 + || ==8.2.2 + || ==8.4.4 + || ==8.6.5 + || ==8.8.4 + || ==8.10.7 + || ==9.0.2 + || ==9.2.2 + +source-repository head + type: git + location: https://github.com/jmorag/bencoding-lens + +library + default-language: Haskell2010 + hs-source-dirs: src + exposed-modules: Data.BEncode.Lens + ghc-options: -Wall + build-depends: + base >=4.4 && <4.18 + , bencoding >=0.4.5.4 && <0.5 + , bytestring >=0.10.4.1 && <0.12 + , lens >=4 && <5.2 + +test-suite bencoding-lens-torrent-test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Torrent.hs + build-depends: + base >=4.4 && <4.18 + , lens >=4 && <5.2 + , bencoding + , bencoding-lens + , http-conduit + , cryptonite + , hspec diff --git a/src/Data/BEncode/Lens.hs b/src/Data/BEncode/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Data/BEncode/Lens.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Copyright : (c) Joseph Morag 2021-2022 +-- License : BSD3 +-- Maintainer: Joseph Morag +-- Stability : experimental +-- Portability: non-portable +-- +-- This module exports orphan instances for @'Ixed' 'BValue'@, @'Plated' +-- 'BValue'@, @'Ixed' 'BDictMap'@, @'Plated' 'BDictMap'@, @'Traversable' +-- 'BDictMap'@, @'FunctorWithIndex' 'BDictMap'@, @'FoldableWithIndex' +-- 'BDictMap'@, and @'TraversbaleWithIndex' 'BDictMap'@. +module Data.BEncode.Lens + ( -- * Prisms + AsBValue (..), + + -- * BDicts and BLists + members, + key, + nth, + values, + ) +where + +import Control.Lens +import Data.BEncode +import Data.BEncode.BDict as BE +import Data.BEncode.Types +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Lazy as Lazy + +-- $setup +-- >>> import Control.Lens +-- >>> import Data.ByteString +-- >>> import Data.BEncode.BDict +-- >>> import Data.BEncode.Types +-- >>> :set -XOverloadedStrings + +-- | Things that can be treated as a 'BValue'. Instances are provided for strict +-- and lazy 'ByteString' as well as 'BValue's themselves. +class AsBValue t where + _BValue :: Prism' t BValue + + -- | + -- >>> ("i3e" :: ByteString) ^? _BInteger + -- Just 3 + _BInteger :: Prism' t BInteger + _BInteger = _BValue . prism' BInteger (\case BInteger x -> Just x; _ -> Nothing) + {-# INLINE _BInteger #-} + + -- | + -- >>> ("0:" :: ByteString) ^? _BString + -- Just "" + -- + -- >>> ("4:spam" :: ByteString) ^? _BString + -- Just "spam" + _BString :: Prism' t BString + _BString = _BValue . prism' BString (\case BString x -> Just x; _ -> Nothing) + {-# INLINE _BString #-} + + -- | + -- >>> ("le" :: ByteString) ^? _BList + -- Just [] + -- + -- >>> ("l4:spam4:eggse" :: ByteString) ^? _BList == Just [BString "spam", BString "eggs"] + -- True + _BList :: Prism' t BList + _BList = _BValue . prism' BList (\case BList x -> Just x; _ -> Nothing) + {-# INLINE _BList #-} + + -- | + -- >>> ("de" :: ByteString) ^? _BDict + -- Just Nil + -- + -- >>> ("d3:cow3:moo4:spam4:eggse" :: ByteString) ^? _BDict == Just (Cons "cow" (BString "moo") (Cons "spam" (BString "eggs") Nil)) + -- True + _BDict :: Prism' t BDict + _BDict = _BValue . prism' BDict (\case BDict x -> Just x; _ -> Nothing) + {-# INLINE _BDict #-} + +instance AsBValue BValue where + _BValue = id + {-# INLINE _BValue #-} + +instance AsBValue Strict.ByteString where + _BValue = prism' (view strict . encode) $ either (const Nothing) Just . decode + {-# INLINE _BValue #-} + +instance AsBValue Lazy.ByteString where + _BValue = prism' encode $ either (const Nothing) Just . decode . view strict + {-# INLINE _BValue #-} + +-- | +-- >>> ("d3:cow3:moo4:spam4:eggse" :: ByteString) ^@.. members +-- [("cow",BString "moo"),("spam",BString "eggs")] +members :: AsBValue t => IndexedTraversal' BKey t BValue +members = _BDict . itraversed +{-# INLINE members #-} + +-- | +-- >>> ("d3:cow3:moo4:spam4:eggse" :: ByteString) ^? key "cow" +-- Just (BString "moo") +key :: AsBValue t => BKey -> Traversal' t BValue +key k = _BDict . ix k +{-# INLINE key #-} + +-- | +-- >>> ("li0ei1ee" :: ByteString) ^? nth 0 +-- Just (BInteger 0) +nth :: AsBValue t => Int -> Traversal' t BValue +nth i = _BList . ix i +{-# INLINE nth #-} + +-- | +-- >>> ("ll1:ae3:cow3:moo4:spam4:eggse" :: ByteString) ^.. values +-- [BList [BString "a"],BString "cow",BString "moo",BString "spam",BString "eggs"] +values :: AsBValue t => IndexedTraversal' Int t BValue +values = _BList . traversed +{-# INLINE values #-} + +------------------------------------------------------------------------------ +-- Orphan instances for lens library interop +------------------------------------------------------------------------------ +instance Traversable BDictMap where + traverse _ Nil = pure Nil + traverse f (Cons k x xs) = Cons k <$> f x <*> traverse f xs + +instance FoldableWithIndex BKey BDictMap + +instance FunctorWithIndex BKey BDictMap + +instance TraversableWithIndex BKey BDictMap where + itraverse _ Nil = pure Nil + itraverse f (Cons k x xs) = Cons k <$> f k x <*> itraverse f xs + +type instance Index (BDictMap a) = BKey + +type instance IxValue (BDictMap a) = a + +type instance Index BValue = BKey + +type instance IxValue BValue = BValue + +instance At (BDictMap a) where + at :: BKey -> Lens' (BDictMap a) (Maybe a) + at k f m = + f mv <&> \case + Nothing -> maybe m (const (delete k m)) mv + Just v' -> insert k v' m + where + mv = BE.lookup k m + {-# INLINE at #-} + +-- | Insert a key value pair into a BDictMap. Overwrites the value for an +-- existing key +insert :: BKey -> a -> BDictMap a -> BDictMap a +insert k v Nil = BE.singleton k v +insert k v bd@(Cons k' x xs) + | k == k' = Cons k v xs + | k < k' = Cons k v bd + | otherwise = Cons k' x (insert k v xs) + +-- | Delete a key from a BDictMap. Returns the BDictMap unchanged if the key is +-- not present. +delete :: BKey -> BDictMap a -> BDictMap a +delete _ Nil = Nil +delete k bd@(Cons k' x xs) + | k == k' = xs + | k > k' = bd + | otherwise = Cons k' x (delete k xs) + +instance Ixed (BDictMap a) + +instance Ixed BValue where + ix i f (BDict o) = BDict <$> ix i f o + ix _ _ v = pure v + {-# INLINE ix #-} + +instance Plated BValue where + plate f (BDict o) = BDict <$> traverse f o + plate f (BList l) = BList <$> traverse f l + plate _ xs = pure xs + {-# INLINE plate #-} diff --git a/test/Torrent.hs b/test/Torrent.hs new file mode 100644 --- /dev/null +++ b/test/Torrent.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedStrings #-} + +import Control.Lens +import Crypto.Hash +import Data.BEncode +import Data.BEncode.Lens +import Network.HTTP.Simple +import Test.Hspec + +main = do + -- Get the ubuntu 20.04 live server torrent file with http-conduit + resp <- httpBS "https://releases.ubuntu.com/20.04/ubuntu-20.04.4-live-server-amd64.iso.torrent" + let torrent = getResponseBody resp + hspec do + it "should get the corrent ubuntu announce string" do + (torrent ^?! key "announce" . _BString) `shouldBe` "https://torrent.ubuntu.com/announce" + it "should get the keys of the top level dict" do + fmap fst (torrent ^@.. members) `shouldBe` ["announce", "announce-list", "comment", "created by", "creation date", "info"] + + it "should get the keys of the info dict" do + fmap fst (torrent ^@.. key "info" . members) `shouldBe` ["length", "name", "piece length", "pieces"] + + it "should find the piece length" do + (torrent ^?! key "info" . key "piece length" . _BInteger) `shouldBe` 262144 + + it "should compute the info hash (see definition below)" do + show (torrent ^?! infoHash) `shouldBe` "b44a0e20fa5b7cecb77156333b4268dfd7c30afb" + +infoHash :: (AsBValue t) => Fold t (Digest SHA1) +infoHash = key "info" . to (hashlazy . encode)